VIBES STUDY 2 ANALYSIS — AGGREGATED DATA
ANONYMIZED
2024-08-07
In VISUALIZATION VIBES project Study 2, participants completed an attitutde eliciation survey, asking questions about their attitude toward (5) stimulus images (data visualizations). Each participant was randomly assigned to one of 6 stimulus blocks, each containing 1 image from each of (4) pseudo-categories (ranging from most abstract to most figural). Each participant started by responding to questions for a single ‘common’ stimulus (that is thus super-powered as it was seen by all participants). Two participant recruitment pools were used: Prolific, with a smaller set of participants recruited from Tumblr (to replicate and compare survey results to Study 1 interviews with participants sourced from Tumblr).
This notebook contains code to replicate quantitative analysis of data from Study 2 reported in the CHI submission. Note that due to limited space, we were unable to report results for all stimulus blocks, and all possible analyses. A separate set of R notebooks are included in the supplementary materials that document analysis of the other blocks not reported here.
This notebook includes analysis and exploration of the full data set (i.e. data aggregated over all stimuli).
1 SETUP
We start by importing data files previously wrangled in
0_VIBES_S2_wrangling.Rmd.
1.1 Import Data
############## IMPORT REFERENCE FILES
ref_stimuli <- readRDS("data/input/REFERENCE/ref_stimuli.rds")
ref_surveys <- readRDS("data/input/REFERENCE/ref_surveys.rds")
ref_labels <- readRDS("data/input/REFERENCE/ref_labels.rds")
ref_labels_abs <- readRDS("data/input/REFERENCE/ref_labels_abs.rds")
############## SETUP Graph Labels
ref_stim_id <- levels(ref_stimuli$ID)
ref_cat_questions <- c("MAKER_ID","MAKER_AGE","MAKER_GENDER")
ref_free_response <- c("MAKER_DETAIL", "MAKER_EXPLAIN", "TOOL_DETAIL", "CHART_EXPLAIN")
ref_conf_questions <- c("MAKER_CONF", "AGE_CONF", "GENDER_CONF", "TOOL_CONF")
ref_sd_questions <- rownames(ref_labels)
ref_sd_questions_abs <- rownames(ref_labels_abs)
# ref_blocks <- c("block1", "block2", "block3", "block4", "block5", "block6")
ref_blocks <- c(1,2,3,4,5,6)############## IMPORT DATA FILES
# df_data <- readRDS("data/output/df_data.rds") #1 row per participant — WIDE
df_participants <- readRDS("data/output/df_participants.rds") #1 row per participant — demographic
df_questions <- readRDS("data/output/df_questions.rds") #1 row per question — LONG
df_sd_questions_wide <- readRDS("data/output/df_sd_questions_wide.rds") # only sd questions WIDE
df_tools <- readRDS("data/output/df_tools.rds") #multiselect format for tools Question
df_actions <- readRDS("data/output/df_actions.rds") # multiselect format for action Question
# # df_graphs_full <- readRDS("data/output/df_graphs_full.rds") #includes free response data
df_graphs <- readRDS("data/output/df_graphs.rds") #only categorical and numeric questions
df_sd_questions_long <- readRDS("data/output/df_sd_questions_long.rds") # only sd questions LONG
### DATA FILES WITH (VARIABLE-WISE) Z-SCORED SEMANTIC DIFFERENTIAL QS
df_graphs_z <- readRDS("data/output/df_graphs_z.rds") #only categorical and numeric questions
df_sd_questions_long_z <- readRDS("data/output/df_sd_questions_long_z.rds") # only sd questions LONG
### DATA FILES WITH ABSOLUTE VALUE SEMANTIC DIFFERENTIAL QS
df_graphs_abs <- readRDS("data/output/df_graphs_abs.rds") #only categorical and numeric questions
df_sd_questions_long_abs <- readRDS("data/output/df_sd_questions_long_abs.rds") # only sd questions LONG1.2 Set up Graphing
# Custom ggplot theme to make pretty plots
# Get the font at https://fonts.google.com/specimen/Barlow+Semi+Condensed
theme_clean <- function() {
theme_minimal(base_family = "Barlow Semi Condensed") +
theme(panel.grid.minor = element_blank(),
plot.title = element_text(family = "BarlowSemiCondensed-Bold"),
axis.title = element_text(family = "BarlowSemiCondensed-Medium"),
strip.text = element_text(family = "BarlowSemiCondensed-Bold",
size = rel(1), hjust = 0),
strip.background = element_rect(fill = "grey80", color = NA))
}
set_theme(base = theme_clean())
############## SETUP Colour Palettes
#https://www.r-bloggers.com/2022/06/custom-colour-palettes-for-ggplot2/
## list of color pallettes
my_colors = list(
politics = c("#184aff","#5238bf", "#4f4a52" ,"#84649c", "#ff0000"),
blackred = c("black","red"),
greys = c("#707070","#999999","#C2C2C2"),
greens = c("#ADC69D","#81A06D","#567E39","#2D5D16","#193E0A"),
smallgreens = c("#ADC69D","#567E39","#193E0A"), ## MALE FEMALE OTHER
olives = c("#CDCEA1","#B8B979","#A0A054","#78783F","#50502A","#35351C"),
lightblues = c("#96C5D2","#61A2B2","#3C8093","#2C6378","#1F4A64"),
darkblues = c("#7AAFE1","#3787D2","#2A73B7","#225E96","#1A4974","#133453"),
reds = c("#D9B8BD","#CE98A2","#B17380","#954E5F","#78263E","#62151F"),
traffic = c("#CE98A2","#81A06D","yellow"),
questions = c("#B17380","#3787D2", "#567E39", "#EE897F"),
tools= c("#D55662","#EE897F","#F5D0AD","#A0B79B","#499678","#2D363A"), #? ... design.....vis...... programming
encounter = c("#8E8E8E","#729B7D"), ##SCROLL ENGAGE
actions2 = c("#8E8E8E","#729B7D"),
actions4 = c("#8E8E8E", "#A3A3A3","#729B7D","#499678"),
actions3 = c("#8E8E8E","#99b898ff","#fdcea8ff"),
actions = c("#8E8E8E","#2A363B","#99b898ff","#fdcea8ff","#ff837bff","#e84a60ff"),
platforms = c("#5D93EA","#FF70CD", "#3BD3F5", "#8B69B5","black"),
amy_gradient = c("#ac57aa", "#9e5fa4", "#90689f", "#827099", "#747894", "#66818e", "#578988", "#499183", "#3b997d", "#2da278", "#1faa72"),
my_favourite_colours = c("#702963", "#637029", "#296370")
)
## function for using palettes
my_palettes = function(name, n, all_palettes = my_colors, type = c("discrete","continuous"), direction = c("1","-1")) {
palette = all_palettes[[name]]
if (missing(n)) {
n = length(palette)
}
type = match.arg(type)
out = switch(type,
continuous = grDevices::colorRampPalette(palette)(n),
discrete = palette[1:n]
)
out = switch(direction,
"1" = out,
"-1" = palette[n:1])
structure(out, name = name, class = "palette")
}############## RETURNS SD STACKED AND COLORED BY BY X
## LOOP STYLE
multi_sd <- function (data, left, right, x, y, color) {
# g <- ggplot(df, aes(y = .data[[x]], x = {{y}}, color = {{color}}))+
g <- ggplot(data, aes(y = .data[[x]], x = .data[[y]], color = .data[[color]]))+
geom_boxplot(width = 0.5) +
geom_jitter(width = 0.1, alpha=0.5) +
scale_y_continuous(limits=c(-1,101)) +
labs(x="", y="") +
coord_flip() +
guides(
y = guide_axis_manual(labels = left),
y.sec = guide_axis_manual(labels = right)
) + theme_minimal()
return(g)
}
############## RETURNS SINGLE SD
## LOOP STYLE
single_sd <- function (data, left, right, x) {
g <- ggplot(data, aes(y = {{x}}, x = ""))+
geom_boxplot(width = 0.5) +
geom_jitter(width = 0.1, alpha=0.5) +
scale_y_continuous(limits=c(-1,101)) +
labs(x="", y="") +
coord_flip() +
guides(
y = guide_axis_manual(labels = left),
y.sec = guide_axis_manual(labels = right)
) + theme_minimal()
return(g)
}
# ######## RETURNS SINGLE SD
# ## APPLY STYLE
plot_sd = function (data, column, type, mean, facet, facet_by, boxplot, labels) {
ggplot(data, aes(y = .data[[column]], x="")) +
{if(boxplot) geom_boxplot(width = 0.5) } +
geom_jitter(width = 0.1, alpha=0.2, {if(facet) aes(color=.data[[facet_by]])}) +
{if(mean)
stat_summary(fun="mean", geom="point", shape=20, size=5, color="blue", fill="blue")
} +
{if(mean)
## assumes data has been passed in with mean column at m
# stat_summary(fun="mean", geom="text", colour="blue", fontface = "bold",
# vjust=-1.25, hjust = 0.50, aes( label=round(..y.., digits=0)))
stat_summary(fun="mean", geom="text", colour="blue", fontface = "bold",
vjust=-1.25, hjust = 0.50, aes( label=round(..y.., digits=0)))
} +
{if(facet) facet_grid(.data[[facet_by]] ~ .)} +
# scale_y_continuous(limits=c(-1,101)) +
labs(x="", y="") +
coord_flip() +
{if(type == "S")
guides(
y = guide_axis_manual(labels = labels[column,"left"]),
y.sec = guide_axis_manual(labels = labels[column,"right"])
)} +
{if(type == "Q")
guides(
y = guide_axis_manual(labels = labels[q,"left"]),
y.sec = guide_axis_manual(labels = labels[q,"right"])
)} +
theme_minimal() +
labs (
caption = column
) + easy_remove_legend()
}2 AD HOCS
2.1 SPARKLINES TABLE
# library(tinytable)
# library(webshot2)
#### CUSTOM HORIZONTAL STACKED BARPLOT
g <- function(d, ...){
p <- d$pal %>% unique
ggplot(d, aes(x="", fill=value)) +
geom_bar(stat="count", position = "stack") +
scale_fill_manual(values=my_colors[[p]]) +
coord_flip() + theme_void() + easy_remove_axes() + easy_remove_legend()
}
## SETUP LIST OF NUMERIC DATAFRAMES
all_q <- c(ref_conf_questions, ref_sd_questions)
## SETUP NUMERIC DATAFRAME
df_num <- df_graphs %>% select(all_of(all_q))
## CALC MEANS
### MEANS
m <- sapply(df_num, FUN=mean)
m <- round(m,1)
m <- paste0("M=",m)
sd <- sapply(df_num, FUN=sd)
sd <- round(sd,1)
sd <- paste0("SD=",sd)
stat <- paste0(m," ",sd)
### CREATE LIST OF CATEGORICAL DATAFRAMES
id = df_graphs %>% select(MAKER_ID) %>%
pivot_longer(cols=1)%>% mutate(pal="reds") %>% as.data.frame()
age = df_graphs %>% select(MAKER_AGE) %>%
pivot_longer(cols=1)%>% mutate(pal="lightblues") %>% as.data.frame()
gender = df_graphs %>% select(MAKER_GENDER) %>%
pivot_longer(cols=1)%>% mutate(pal="smallgreens") %>% as.data.frame()
tools <- df_tools %>% select(TOOL_ID) %>%
pivot_longer(cols=1)%>% mutate(pal="tools") %>% as.data.frame()
encounter = df_graphs %>% select(ENCOUNTER) %>%
pivot_longer(cols=1)%>% mutate(pal="encounter") %>% as.data.frame()
action2 = df_actions %>% select(CHART_ACTION2) %>%
pivot_longer(cols=1)%>% mutate(pal="actions2") %>% as.data.frame()
action4 = df_actions %>% select(CHART_ACTION4) %>%
pivot_longer(cols=1)%>% mutate(pal="actions4") %>% as.data.frame()
df_cat <- list()
df_cat[["MAKER_ID"]] <- id
df_cat[["MAKER_AGE"]] <- age
df_cat[["MAKER_GENDER"]] <- gender
df_cat[["TOOL_ID"]] <- tools
df_cat[["ENCOUNTER"]] <- encounter
df_cat[["CHART_ACTION2"]] <- action2
df_cat[["CHART_ACTION4"]] <- action4
## CALC CAT PROPORTIONS
n <- nrow(id)
m_id <- table(id) %>% as.data.frame() %>% mutate(prop = round(Freq/n, 2)*100) %>% map_df(rev) #reverse reading order
stat_id <- paste0(m_id$value, "(", m_id$prop,"%)") %>% unlist() %>% paste0(collapse=''," ")
n <- nrow(age)
m_age <- table(age) %>% as.data.frame() %>% mutate(prop = round(Freq/n, 2)*100)%>% map_df(rev)
stat_age <- paste0(m_age$value, "(", m_age$prop,"%)") %>% unlist() %>% paste0(collapse=''," ")
n <- nrow(gender)
m_gender <- table(gender) %>% as.data.frame() %>% mutate(prop = round(Freq/n, 2)*100)%>% map_df(rev)
stat_gender <- paste0(m_gender$value, "(", m_gender$prop,"%)")%>% unlist() %>% paste0(collapse=''," ")
n <- nrow(tools)
m_tools <- table(tools) %>% as.data.frame() %>% mutate(prop = round(Freq/n, 2)*100)%>% map_df(rev)
stat_tools <- paste0(m_tools$value, "(", m_tools$prop,"%)") %>% unlist() %>% paste0(collapse=''," ")
n <- nrow(encounter)
m_encounter <- table(encounter) %>% as.data.frame() %>% mutate(prop = round(Freq/n, 2)*100)%>% map_df(rev)
stat_encounter <- paste0(m_encounter$value, "(", m_encounter$prop,"%)") %>% unlist() %>% paste0(collapse=''," ")
n <- nrow(action2)
m_action2 <- table(action2) %>% as.data.frame() %>% mutate(prop = round(Freq/n, 2)*100)%>% map_df(rev)
stat_action2 <- paste0(m_action2$value, "(", m_action2$prop,"%)") %>% unlist() %>% paste0(collapse=''," ")
n <- nrow(action4)
m_action4 <- table(action4) %>% as.data.frame() %>% mutate(prop = round(Freq/n, 2)*100)%>% map_df(rev)
stat_action4 <- paste0(m_action4$value, "(", m_action4$prop,"%)") %>% unlist() %>% paste0(collapse=''," ")
## SETUP QUESTIONS
questions <- c(ref_cat_questions, "TOOL_ID", "ENCOUNTER", "CHART_ACTION2", "CHART_ACTION4", ref_conf_questions, ref_sd_questions)
#### SETUP TABLE
tab <- data.frame(
VARIABLE = questions,
DISTRIBUTION = "",
STATISTICS = c(stat_id, stat_age, stat_gender, stat_tools, stat_encounter, stat_action2, stat_action4, stat)
# c("","","","","","","",stat)
)
### RENDER TABLE
t <- tinytable::tt(tab, theme = "void") %>%
plot_tt(j=2, i= 1:7, fun=g, data = df_cat, height = 1.5) %>%
plot_tt(j=2, i= 8:22, fun="density", data = df_num, color="darkgrey") %>%
style_tt(j=2, align="c")
t| VARIABLE | DISTRIBUTION | STATISTICS |
|---|---|---|
| MAKER_ID |  |
political(16%) news(19%) business(20%) education(25%) organization(7%) individual(12%) |
| MAKER_AGE |  |
gen-z(9%) millennial(40%) gen-x(41%) boomer(10%) |
| MAKER_GENDER |  |
Male(59%) Female(34%) Other(7%) |
| TOOL_ID |  |
programming(4%) viz_advanced(22%) viz_basic(17%) design_advanced(24%) design_basic(23%) ?(9%) |
| ENCOUNTER |  |
engage(59%) scroll(41%) |
| CHART_ACTION2 |  |
something(46%) nothing(54%) |
| CHART_ACTION4 |  |
seek_info(28%) comment_share(14%) unfollow_block(4%) nothing(54%) |
| MAKER_CONF |  |
M=61.6 SD=23.4 |
| AGE_CONF |  |
M=60 SD=21.3 |
| GENDER_CONF |  |
M=54.2 SD=25.4 |
| TOOL_CONF |  |
M=64.7 SD=23.3 |
| MAKER_DESIGN |  |
M=48.1 SD=28.3 |
| MAKER_DATA |  |
M=42.7 SD=27.7 |
| MAKER_POLITIC |  |
M=47 SD=18.7 |
| MAKER_ARGUE |  |
M=54.9 SD=19.9 |
| MAKER_SELF |  |
M=44 SD=19.6 |
| MAKER_ALIGN |  |
M=52.7 SD=18.1 |
| MAKER_TRUST |  |
M=58 SD=18.6 |
| CHART_TRUST |  |
M=54.6 SD=23.2 |
| CHART_INTENT |  |
M=41.3 SD=31.5 |
| CHART_LIKE |  |
M=48.6 SD=26.4 |
| CHART_BEAUTY |  |
M=49.5 SD=28.9 |
if(GRAPH_SAVE){
save_tt(t, output="figs/tables/sparklines.png", overwrite = TRUE)
save_tt(t, output="figs/tables/sparklines.tex", overwrite = TRUE)
}3 FULL SAMPLE ANALYSIS
As we argue in our manuscript, we understand that an individual’s response to a visualization (both inferences about data, as well as any other behaviours) will vary based on properties of: (1) the visualization, (2) the data, (3) the individual, and (4) the situational context. Thus, our survey is not designed to uncover consistencies in behaviour, but rather, explore the nature of variance in behaviour as a function of the individual and visualization.
(n = 318 ) survey respondents answered questions about some subset of the stimuli, (common stimulus B0-0 and 4 additional images defined as a block), yielding (o = 1590) stimulus-level observations.
3.1 SAMPLE
3.1.1 Sample Demographics
df <- df_participants
## FOR DESCRIPTIVES PARAGRAPH
# #PROLIFIC
df.p <- df %>% filter(Distribution == "PROLIFIC")
desc.gender.p <- table(df.p$D_gender) %>% prop.table()
names(desc.gender.p) <- levels(df.p$D_gender)
p_participants <- nrow(df.p)
# #TUMBLR
df.t <- df %>% filter(Distribution == "TUMBLR")
desc.gender.t <- table(df.t$D_gender) %>% prop.table()
names(desc.gender.t) <- levels(df.t$D_gender)
t_participants <- nrow(df.t)For study 2, a total of 318 participants were recruited from US-located English speaking users of TUMBLR (n = 78) and PROLIFIC (n = 240).
240 individuals from PROLIFIC participated in Study 2, ( 54% Female, 42% Male, 3% Non-binary, 1% Other).
78 individuals from Tumblr participated in Study 2, ( 36% Female, 5% Male, 40% Non-binary, 19% Other). Note that a higher proportion of participants recruited from TUMBLR report identities other than cis-gender Female and cis-gender Male.
3.1.2 Study Response Time
df <- df_participants
## for descriptives paragraph
p.desc.duration <- psych::describe(df %>% filter(Distribution=="PROLIFIC") %>% pull(duration.min))
t.desc.duration <- psych::describe(df %>% filter(Distribution=="TUMBLR") %>% pull(duration.min))
a.desc.duration <- psych::describe(df %>% pull(duration.min))PROLIFIC SAMPLE (n = 240 ) participant response times ranged from 13.97 to 216.18 minutes, with a mean response time of 42.49 minutes, SD = 21.15.
TUMBLR SAMPLE (n = 78 ) participant response times ranged from 10.88 to 227.57 minutes, with a mean response time of 51.93 minutes, SD = 35.47.
Across the entire sample, (n = 318 ) participant response times ranged from 10.88 to 227.57 minutes, with a mean response time of 44.8 minutes, SD = 25.68.
rm(df, df.p, df.t, p.desc.duration, t.desc.duration, desc.gender.p, desc.gender.t, p_participants, t_participants)3.1.3 Setup sample data frame
#full stimulus-level data
df_full <- df_graphs %>%
mutate(
STUDY = "" #dummy variable for univariate visualizations
)
# %>%
# mutate(MAKER_ID = fct_rev(MAKER_ID))3.2 CONFIDENCE
When asking participants to identify the type, age and gender of the maker of a visualization, we also asked participants to indicate their confidence in these choices.
Across all participants and all stimuli, are these (categorical) questions answered with the same degree of confidence?
Here we examine both the central tendency (mean) and shape of the distribution for each confidence variable.
df <- df_full %>% select(PID, Distribution, STIMULUS,MAKER_CONF, AGE_CONF, GENDER_CONF, TOOL_CONF) %>%
pivot_longer(
cols = c(MAKER_CONF, AGE_CONF, GENDER_CONF, TOOL_CONF),
names_to = "QUESTION",
values_to = "CONFIDENCE"
) %>%
mutate(
QUESTION = factor(QUESTION, levels=c("MAKER_CONF","AGE_CONF","GENDER_CONF","TOOL_CONF" ) )
) %>%
group_by(QUESTION) %>%
mutate(
m=round(mean(CONFIDENCE),0) #calc mean for showing in plots
)
## B
## CONFIDENCE ACROSS QUESTIONS (all stimuli, all Pps)
## BOXPLOT W/ JITTER
B <- df %>%
ggplot(aes(x=QUESTION, y= CONFIDENCE)) +
geom_boxplot(width = 0.5) +
geom_jitter(alpha = 0.25, position=position_dodge2(width = 0.25)) +
## MEAN
stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold", size=3,
vjust=+0.5, hjust = -1.5, aes( label=round(m, digits=0)))+
stat_summary(fun=mean, geom="point", size=2, color="blue", fill="blue") +
theme_minimal() +
labs(title = "Confidence by Survey Question", caption = "(mean in blue)")
## R
## CONFIDENCE ACROSS QUESTIONS (all stimuli, all Pps)
## RIDGEPLOT W/ INTERVAL MEAN
R <- df %>%
ggplot(aes(x=CONFIDENCE, y=fct_rev(QUESTION), fill=fct_rev(QUESTION))) +
geom_density_ridges(scale = 0.65, alpha = 0.75, quantile_lines = TRUE) +
scale_x_continuous(limits = c(0,100))+
scale_fill_manual(values = my_palettes(name="questions", direction = "-1"), name = "", guide = guide_legend(reverse = TRUE)) +
stat_pointinterval(side = "bottom", scale = 0.7, slab_linewidth = NA, point_interval = "mean_qi") +
## MEAN
stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold", size=3,
vjust=+2.5, hjust = 0.50, aes( label=round(m, digits=0)))+
stat_summary(fun=mean, geom="point", size=2, color="blue", fill="blue") +
theme_minimal() +
labs(title = "Confidence by Survey Question", y = "QUESTION", caption =" (mean in blue)") +
easy_remove_legend()
(B+R)## Picking joint bandwidth of 4.54
if(GRAPH_SAVE){ggsave(plot = (B+R), path="figs/level_aggregated/distributions", filename =paste0("all_confidence.png"), units = c("in"), width = 14, height = 8 , bg='#ffffff' )}INTERPRETATION Aggregated across all participants and all stimuli, the average confidence scores for each question (maker id, age, gender, tool id) are similar, with slightly lower confidence for the GENDER question. This tells us there is enough variance in response to each question for the measure to be meaningful, and so we will follow up by investigating confidence at the STIMULUS level.
3.2.1 CONFIDENCE VARIANCE
## DATAFRAME WITH LONG FORM CONFIDENCE SCORES
df_conf_long <- df_graphs %>%
select(PID, STIMULUS, BLOCK, MAKER_CONF, AGE_CONF, GENDER_CONF, TOOL_CONF) %>%
pivot_longer(
cols = c("MAKER_CONF", "AGE_CONF", "GENDER_CONF", "TOOL_CONF"),
names_to = "QUESTION")
#
# print("QUESTION LEVEL CONFIDENCE (ALL P, ALL S)")
# (q_conf <- df_conf_long %>%
# group_by(QUESTION) %>%
# summarize(
# m = mean(value),
# sd = sd(value)
# ))
print("SD AND RANGES OF PARTICIPANT CONFIDENCE [ALL STIMULI]")## [1] "SD AND RANGES OF PARTICIPANT CONFIDENCE [ALL STIMULI]"## PARTICIPANT LOW VARIANCE
## proportion of participants with less than 20 point variance in a particular question [across 5 stim]
(df_lowvar_q <- df_graphs %>%
# filter(STIMULUS!="B0-0") %>%
# filter(BLOCK %in% c("B1","B2")) %>%
select(PID, STIMULUS, BLOCK, MAKER_CONF, AGE_CONF, GENDER_CONF, TOOL_CONF) %>%
pivot_longer(
cols = c("MAKER_CONF", "AGE_CONF", "GENDER_CONF", "TOOL_CONF"),
names_to = "QUESTION") %>%
group_by(PID) %>%
summarise(
count_pid = n(), #5 trials of each question
mean_pid = mean(value),
min_pid = min(value),
max_pid = max(value),
range_pid = max_pid-min_pid,
low_range_pid = ifelse(range_pid < 20, TRUE, FALSE),
sd_pid = sd(value),
low_sd_pid = ifelse(sd_pid < 10, TRUE, FALSE)) %>%
summarise(
n = n(), #318p X 5 stimuli
n_pid = sum(count_pid),
n_low_range = sum((low_range_pid==TRUE)),
prop.low_range = n_low_range / n,
n_low_sd = sum((low_sd_pid==TRUE)),
prop.low_sd = n_low_sd / n
)) ## # A tibble: 1 × 6
## n n_pid n_low_range prop.low_range n_low_sd prop.low_sd
## <int> <int> <int> <dbl> <int> <dbl>
## 1 318 6360 4 0.0126 39 0.123# print("SD AND RANGES OF PARTICIPANT CONFIDENCE SCORES BY QUESTION")
# ## PARTICIPANT - QUESTION LOW VARIANCE
# ## proportion of participants with less than 20 point variance in a particular question [across 5 stim]
# (df_lowvar_q <- df_graphs %>%
# # filter(STIMULUS!="B0-0") %>%
# # filter(BLOCK %in% c("B1","B2")) %>%
# select(PID, STIMULUS, BLOCK, MAKER_CONF, AGE_CONF, GENDER_CONF, TOOL_CONF) %>%
# pivot_longer(
# cols = c("MAKER_CONF", "AGE_CONF", "GENDER_CONF", "TOOL_CONF"),
# names_to = "QUESTION") %>%
# group_by(PID, QUESTION) %>%
# summarise(
# count_pidq = n(), #5 trials of each question
# mean_pidq = mean(value),
# min_pidq = min(value),
# max_pidq = max(value),
# range_pidq = max_pidq-min_pidq,
# low_range_pidq = ifelse(range_pidq < 20, TRUE, FALSE),
# sd_pidq = sd(value),
# low_sd_pidq = ifelse(sd_pidq < 10, TRUE, FALSE)) %>%
# group_by(QUESTION) %>%
# summarise(
# n = n(), #318p X 5 stimuli
# n_pidq = sum(count_pidq),
# n_low_range = sum((low_range_pidq==TRUE)),
# prop.low_range = n_low_range / n,
# n_low_sd = sum((low_sd_pidq==TRUE)),
# prop.low_sd = n_low_sd / n
# ))
### participants with lowest
## PARTICIPANT LOW VARIANCE
## proportion of participants with less than 20 point variance in a particular question [across 5 stim]
((df_low <- df_graphs %>%
# filter(STIMULUS!="B0-0") %>%
# filter(BLOCK %in% c("B1","B2")) %>%
select(PID, MAKER_CONF, AGE_CONF, GENDER_CONF, TOOL_CONF) %>%
pivot_longer(
cols = c("MAKER_CONF", "AGE_CONF", "GENDER_CONF", "TOOL_CONF"),
names_to = "QUESTION") %>%
group_by(PID) %>%
summarise(
pid = unique(PID),
count_pid = n(), #5 trials of each question
mean_pid = mean(value),
min_pid = min(value),
max_pid = max(value),
range_pid = max_pid-min_pid,
low_range_pid = ifelse(range_pid < 20, TRUE, FALSE),
sd_pid = sd(value),
low_sd_pid = ifelse(sd_pid < 10, TRUE, FALSE)) ))## # A tibble: 318 × 10
## PID pid count_pid mean_pid min_pid max_pid range_pid low_range_pid sd_pid
## <fct> <fct> <int> <dbl> <dbl> <dbl> <dbl> <lgl> <dbl>
## 1 R_11… R_11… 20 83.4 70 100 30 FALSE 7.85
## 2 R_13… R_13… 20 63.6 25 90 65 FALSE 19.7
## 3 R_1A… R_1A… 20 43.8 0 95 95 FALSE 26.5
## 4 R_1a… R_1a… 20 84.8 51 96 45 FALSE 12.9
## 5 R_1a… R_1a… 20 37.1 24 91 67 FALSE 17.6
## 6 R_1B… R_1B… 20 66.3 25 84 59 FALSE 15.5
## 7 R_1C… R_1C… 20 47.6 0 83 83 FALSE 29.8
## 8 R_1D… R_1D… 20 66.1 30 88 58 FALSE 14.0
## 9 R_1d… R_1d… 20 64.0 3 83 80 FALSE 21.4
## 10 R_1E… R_1E… 20 66 38 92 54 FALSE 14.9
## # ℹ 308 more rows
## # ℹ 1 more variable: low_sd_pid <lgl>Looking at confidence scores by participant aggregating over all stimuli and all questions, we see that 39/318 (12%) participants had less SD of less than 10 points (on 100 point scale) in confidence.
3.3 MAKER ID
Participants were asked:
Who do you think is most likely responsible for having this
image created?
options: (select one). The response is stored as
MAKER_ID
business or corporation
journalist or news outlet
educational or academic institution
government or political organization
other organization
an individual]
Participants were also asked: Please rate your confidence in
this choice. The response is stored as MAKER_CONF
.
#FILTER DATASET
df <- df_full
## D
## MAKER IDENTIFICATION AGGREGATED (all)
## GGSTATSPLOT
##############################
#hack for consistent ordering of ggstats bar plot
dx <- df %>% mutate( MAKER_ID = fct_rev(MAKER_ID) )
S <- ggbarstats( data = dx, x = MAKER_ID, y = STUDY,
legend.title = "MAKER ID") +
scale_fill_manual(values = my_palettes(name="reds", direction = "1")) +
theme_minimal() +
labs( title = "", x = "", y="") +
theme(aspect.ratio = 1)## Scale for fill is already present.
## Adding another scale for fill, which will replace the existing scale.##############################
## H
## HALF EYE SLAB GGDIST
##############################
H <- df %>%
group_by(MAKER_ID) %>%
mutate(count = n(), m = mean(MAKER_CONF)) %>%
ggplot(aes(y = MAKER_CONF, x = fct_rev(MAKER_ID), fill = fct_rev(MAKER_ID))) +
stat_halfeye(scale=0.55, density="bounded", point_interval = "mean_qi", normalize= "all") +
## MEAN
stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold", size = 2,
vjust=2.5, hjust = .5, aes( label=round(m, digits=0)))+
stat_summary(fun=mean, geom="point", shape=20, size=3, color="blue", fill="blue") +
scale_fill_manual(values = my_palettes(name="reds", direction = "-1"), guide = guide_legend(reverse = TRUE)) +
geom_text(aes(label= paste0("n=",count) , y = 5), color = "black",
size = 3, nudge_x=0.35) +
labs(y="Maker ID Confidence", x="") +
theme_minimal() +
easy_remove_legend()+
coord_flip()
##############################
(p <- (S + H)) + plot_annotation(
title = "Maker ID and Confidence",
# subtitle = "the categories of MAKER ID were chosen in similar proportion,
# and both the mean (in blue) and shape of distribution of confidence scores is similar across values of Maker ID",
caption = "(blue indicates mean)"
)
if(GRAPH_SAVE){ggsave(plot = p, path="figs/level_aggregated/categoricals", filename =paste0("all_maker_id.png"), units = c("in"), width = 14, height = 8 , bg='#ffffff' )}INTERPRETATION The distribution of maker types
is remarkably consitent across levels of the MAKER_ID
variable, with the exception of ‘organization’. Howerver, as 4 of the 6
categories are specific kinds of organizatations, this is not
surprising. The believe this distribution is likely a function of the
diversity of stimuli we selected. We will address this hypothesis in
block-level analysis, asking whether their is variance in the
distribution of MAKER_ID between stimuli. Notably, the
confidence scores are similar (both in mean and shape of distribution)
regardless of the MAKER_ID, indicating that in general,
there is no particular maker identification for which participants have
less confidence.
3.4 MAKER AGE
Participants were asked: Take a moment to imagine the
person(s) responsible for creating the image. What generation are they
most likely from?
options: (select one) The response was saved as
MAKER_AGE
boomers (60+ years old)
Generation X (44-59 years old)
Millennials (28-43 years old)
Generation Z (12 - 27 years old]
Participants were asked: Please rate your confidence in this
choice. The response is stored as AGE_CONF .
#FILTER DATASET
df <- df_full
## D
## MAKER IDENTIFICATION AGGREGATED (all)
## GGSTATSPLOT
##############################
#hack for consistent ordering of ggstats bar plot
dx <- df %>% mutate( MAKER_AGE = fct_rev(MAKER_AGE) )
S <- ggbarstats( data = dx, x = MAKER_AGE, y = STUDY,
legend.title = "MAKER AGE") +
scale_fill_manual(values = my_palettes(name="lightblues", direction = "1")) +
theme_minimal() +
labs( title = "", x = "", y="") +
theme(aspect.ratio = 1)## Scale for fill is already present.
## Adding another scale for fill, which will replace the existing scale.##############################
## H
## HALF EYE SLAB GGDIST
##############################
H <- df %>%
group_by(MAKER_AGE) %>%
mutate(count = n(), m = mean(AGE_CONF)) %>%
ggplot(aes(y = AGE_CONF, x = fct_rev(MAKER_AGE), fill = fct_rev(MAKER_AGE))) +
stat_halfeye(scale=0.55, density="bounded", point_interval = "mean_qi", normalize= "all") +
## MEAN
stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold", size = 2,
vjust=2.5, hjust = .5, aes( label=round(..y.., digits=0)))+
stat_summary(fun=mean, geom="point", shape=20, size=3, color="blue", fill="blue") +
scale_fill_manual(values = my_palettes(name="lightblues", direction = "-1"), guide = guide_legend(reverse = TRUE)) +
geom_text(aes(label= paste0("n=",count) , y = 5), color = "black",
size = 3, nudge_x=0.35) +
labs(y="Maker AGE Confidence", x="") +
theme_minimal() +
easy_remove_legend()+
coord_flip()
##############################
(p <- (S + H)) + plot_annotation(
title = "Maker AGE and Confidence",
# subtitle = "The value
# distribution of confidence scores is similar across values of Maker AGE",
caption = "(blue indicates mean)"
)
if(GRAPH_SAVE){ggsave(plot = p, path="figs/level_aggregated/categoricals", filename =paste0("all_maker_age.png"), units = c("in"), width = 14, height = 8 , bg='#ffffff' )}INTERPRETATION The distribution of maker ages is
distributed as we would expect if participants are answering the
question with some sense of the maker’s occupation in mind, thus
answering with generations that are mostly likely of working age (gen X,
millennial). As with MAKER_ID, confidence scores are
similar (both in mean and shape of distribution) across all levels of
MAKER_AGE, indicating that in general, there is no
MAKER_AGE for which participants have less
confidence.
3.5 MAKER GENDER
Participants were asked: Take a moment to imagine the
person(s) responsible for creating the image. What gender do they most
likely identify with?
options: [female / male / other ] (select one).
Responses were stored as MAKER_GENDER.
Participants were asked: Please rate your confidence in this
choice. The response is stored as GENDER_CONF
.
#FILTER DATASET
df <- df_full
## D
## MAKER IDENTIFICATION AGGREGATED (all)
## GGSTATSPLOT
##############################
#hack for consistent ordering of ggstats bar plot
dx <- df %>% mutate( MAKER_GENDER = fct_rev(MAKER_GENDER) )
S <- ggbarstats( data = dx, x = MAKER_GENDER, y = STUDY,
legend.title = "MAKER GENDER") +
scale_fill_manual(values = my_palettes(name="smallgreens", direction = "1")) +
theme_minimal() +
labs( title = "", x = "", y="") +
theme(aspect.ratio = 1)## Scale for fill is already present.
## Adding another scale for fill, which will replace the existing scale.##############################
## H
## HALF EYE SLAB GGDIST
##############################
H <- df %>%
group_by(MAKER_GENDER) %>%
mutate(count = n(), m = mean(GENDER_CONF), MAKER_GENDER = fct_rev(MAKER_GENDER)) %>%
ggplot(aes(y = GENDER_CONF, x = MAKER_GENDER, fill = MAKER_GENDER)) +
stat_halfeye(scale=0.55, density="bounded", point_interval = "mean_qi", normalize= "all") +
## MEAN
stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold", size = 2,
vjust=2.5, hjust = .5, aes( label=round(..y.., digits=0)))+
stat_summary(fun=mean, geom="point", shape=20, size=3, color="blue", fill="blue") +
scale_fill_manual(values = my_palettes(name="smallgreens", direction = "-1"), guide = guide_legend(reverse = TRUE)) +
geom_text(aes(label= paste0("n=",count) , y = 5), color = "black",
size = 3, nudge_x=0.35) +
labs(y="Maker GENDER Confidence", x="") +
theme_minimal() +
easy_remove_legend()+
coord_flip()
##############################
(p <- (S + H)) + plot_annotation(
title = "Maker GENDER and Confidence",
# subtitle = "The value
# distribution of confidence scores is similar across values of Maker AGE",
caption = "(blue indicates mean)"
)
if(GRAPH_SAVE){ggsave(plot = p, path="figs/level_aggregated/categoricals", filename =paste0("all_maker_gender.png"), units = c("in"), width = 14, height = 8 , bg='#ffffff' )}INTERPRETATION: The distribution of maker
genders is not evenly distributed between men and women as we might
expect. We suspect it is most likely that the ‘male’ category serves as
a default value for the maker gender, in the absence of any particular
feature of stimulus that viewers interpret as strongly feminine. This
hypothesis is grounded in the free response data, where respondents tend
to explicitly describe gender in the presence of a design feature
consistent with modern western stereotypes (such us pink indicating
feminine, or aggressive indicating masculine).
3.6 TOOL ID
Participants were asked: What tools do you think were most
likely used to create this image?
options: (select all that apply). The response was
saved as variable TOOL_ID (multi-select)
basic graphic design software (e.g. Canva, or similar)
advanced graphic design software (e.g. Adobe Illustrator, Figma, or similar)
data visualization software (e.g. Tableau, PowerBI, or similar)
general purpose software (e.g. MS Word/Excel, Google Sheets, or similar)
programming language (e.g. R, python, javascript, or similar)
Participants were asked: Please rate your confidence in this
choice. The response is stored as TOOL_CONF .
#FILTER DATASET
df <- df_tools %>%
mutate(
STUDY = ""
)
## D
## MAKER IDENTIFICATION AGGREGATED (all)
## GGSTATSPLOT
##############################
#hack for consistent ordering of ggstats bar plot
S <- ggbarstats( data = df, x = TOOL_ID, y = STUDY,
legend.title = "TOOL ID") +
scale_fill_manual(values = my_palettes(name="tools", direction = "-1"), guide = guide_legend(reverse = TRUE)) +
theme_minimal() +
labs( title = "", x = "", y="") +
theme(aspect.ratio = 1)## Scale for fill is already present.
## Adding another scale for fill, which will replace the existing scale.##############################
## H
## HALF EYE SLAB GGDIST
##############################
H <- df %>%
group_by(TOOL_ID) %>%
mutate(count = n(), m = mean(TOOL_CONF)) %>%
ggplot(aes(y = TOOL_CONF, x = TOOL_ID, fill = TOOL_ID)) +
stat_halfeye(scale=0.55, density="bounded", point_interval = "mean_qi", normalize= "all") +
## MEAN
stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold", size = 2,
vjust=2.5, hjust = .5, aes( label=round(..y.., digits=0)))+
stat_summary(fun=mean, geom="point", shape=20, size=3, color="blue", fill="blue") +
scale_fill_manual(values = my_palettes(name="tools", direction = "1"), guide = guide_legend(reverse = TRUE)) +
geom_text(aes(label= paste0("n=",count) , y = 5), color = "black",
size = 3, nudge_x=0.35) +
labs(y="TOOL ID Confidence", x="") +
theme_minimal() +
easy_remove_legend()+
coord_flip()
##############################
(p <- (S + H)) + plot_annotation(
title = "TOOL ID and Confidence",
# subtitle = "The value
# distribution of confidence scores is similar across values of Maker AGE",
caption = "(blue indicates mean)"
)
if(GRAPH_SAVE){ggsave(plot = p, path="figs/level_aggregated/categoricals", filename =paste0("all_tool_id.png"), units = c("in"), width = 14, height = 8 , bg='#ffffff' )}INTERPRETATION We had no expectations with respect to the distribution of values in tool identification, but note that are roughly even across categories (exception of ‘unknown’ and ‘programming’), and the confidence scores are similar.
3.7 ENCOUNTER CHOICE
The first question each participant saw in each stimulus block was: As you’re scrolling through your feed, you see this image. What would you do?
options: keep scrolling, pause and look at the image. (select one)
The response was saved as variable ENCOUNTER
## B
## ENCOUNTER BY STIMULUS
## GGSTATSPLOT
(p <- df_full %>%
ggbarstats(
x = ENCOUNTER, y = STUDY,
legend.title = "ENCOUNTER",
results.subtitle = FALSE) +
scale_fill_manual(values = my_palettes(name="encounter", direction = "-1"))+
theme_minimal() +
labs( title = "ENCOUNTER Choice ", subtitle = "", x = "")
)## Scale for fill is already present.
## Adding another scale for fill, which will replace the existing scale.
if(GRAPH_SAVE){ggsave(plot = p, path="figs/level_aggregated/categoricals", filename =paste0("all_encounter.png"), units = c("in"), width = 14, height = 8 , bg='#ffffff' )}INTERPRETATION In roughly 10% more trials (participant + stimulus), participants indicated they would likely engage with the image rather than scroll past it.
3.8 ACTION CHOICE
The last question participants were asked in each stimulus block was: Imagine you encounter the following image while scrolling. Which of the following are you most likely to do?
options: (select all that apply). The response was saved as variable
CHART_ACTION
post a comment
share/repost
share/repost WITH comment
look up more information about the topic or source
unfollow/block the source
NOTHING—just keep scrolling
#FILTER DATASET
df <- df_actions
### FULL ACTION
## D
## GGSTATSPLOT
##############################
#hack for consistent ordering of ggstats bar plot
dx <- df %>% mutate( CHART_ACTION = fct_rev(CHART_ACTION) )
S <- ggbarstats( data = dx, x = CHART_ACTION, y = STIMULUS,
legend.title = "ACTION",
results.subtitle = FALSE) +
scale_fill_manual(values = my_palettes(name="actions", direction = "1")) +
theme_minimal() +
labs( title = "CHART ACTION by STIMULUS", x = "", y="") +
theme(aspect.ratio = 1)## Scale for fill is already present.
## Adding another scale for fill, which will replace the existing scale.##############################
if(GRAPH_SAVE){ggsave(plot = S, path="figs/level_aggregated/categoricals", filename =paste0("all_action.png"), units = c("in"), width = 14, height = 8 , bg='#ffffff' )}
S
### FULL ACTION
## D
## GGSTATSPLOT
##############################
#hack for consistent ordering of ggstats bar plot
dx <- df %>% mutate( CHART_ACTION4 = fct_rev(CHART_ACTION4) )
S <- ggbarstats( data = dx, x = CHART_ACTION4, y = STIMULUS,
legend.title = "ACTION",
results.subtitle = FALSE) +
scale_fill_manual(values = my_palettes(name="actions4", direction = "1")) +
theme_minimal() +
labs( title = "CHART ACTION [4] by STIMULUS", x = "", y="") +
theme(aspect.ratio = 1)## Scale for fill is already present.
## Adding another scale for fill, which will replace the existing scale.##############################
if(GRAPH_SAVE){ggsave(plot = S, path="figs/level_aggregated/categoricals", filename =paste0("all_action4.png"), units = c("in"), width = 14, height = 8 , bg='#ffffff' )}
S
### FULL ACTION
## D
## GGSTATSPLOT
##############################
#hack for consistent ordering of ggstats bar plot
dx <- df %>% mutate( CHART_ACTION3 = fct_rev(CHART_ACTION3) )
S <- ggbarstats( data = dx, x = CHART_ACTION3, y = STIMULUS,
legend.title = "ACTION",
results.subtitle = FALSE) +
scale_fill_manual(values = my_palettes(name="actions3", direction = "1")) +
theme_minimal() +
labs( title = "CHART ACTION [3] by STIMULUS", x = "", y="") +
theme(aspect.ratio = 1)## Scale for fill is already present.
## Adding another scale for fill, which will replace the existing scale.##############################
if(GRAPH_SAVE){ggsave(plot = S, path="figs/level_aggregated/categoricals", filename =paste0("all_action3.png"), units = c("in"), width = 14, height = 8 , bg='#ffffff' )}
S
### FULL ACTION
## D
## GGSTATSPLOT
##############################
#hack for consistent ordering of ggstats bar plot
dx <- df %>% mutate( CHART_ACTION2 = fct_rev(CHART_ACTION2) )
S <- ggbarstats( data = dx, x = CHART_ACTION2, y = STIMULUS,
legend.title = "ACTION",
results.subtitle = FALSE) +
scale_fill_manual(values = my_palettes(name="actions2", direction = "1")) +
theme_minimal() +
labs( title = "CHART ACTION [2] by STIMULUS", x = "", y="") +
theme(aspect.ratio = 1)## Scale for fill is already present.
## Adding another scale for fill, which will replace the existing scale.##############################
if(GRAPH_SAVE){ggsave(plot = S, path="figs/level_aggregated/categoricals", filename =paste0("all_action2.png"), units = c("in"), width = 14, height = 8 , bg='#ffffff' )}
S
INTERPRETATION A high proportion of participants answered ‘nothing’ chart action, which is not surprising given the social media context. I am surprised to see such a high proportion answering that they would seek further information!
3.9 PLATFORM CHOICE
Before starting the experimental blocks, participants were asked: Please choose a social media platform to imagine you are engaging with during this study
options: (select one). The response was saved as variable
PLATFORM
Twitter/X, Tumblr
LinkedIn
Instagram
Facebook
## B
## PLATFORM BY STIMULUS
## GGSTATSPLOT
#hack for consistent ordering of ggstats bar plot
(p <- df_full %>%
ggbarstats(
x = PLATFORM, y = STUDY,
legend.title = "PLATFORM",
results.subtitle = FALSE) +
scale_fill_manual(values = my_palettes(name="platforms", direction = "-1"))+
theme_minimal() +
labs( title = "PLATFORM Choice ", subtitle = "", x = "")
)## Scale for fill is already present.
## Adding another scale for fill, which will replace the existing scale.
if(GRAPH_SAVE){ggsave(plot = p, path="figs/level_aggregated/categoricals", filename =paste0("all_platform_choice.png"), units = c("in"), width = 14, height = 8 , bg='#ffffff' )}INTERPRETATION We had no expectations about the distribution of social media platform.
3.10 SEMANTIC DIFFERENTIALS
Participants were also asked to rate certain characteristics of the chart, or its maker, along a semantic differential scale, implemented in Qualtrics as a continuous slider ranging from 0 -> 100 with biploar adjectives at the end of each scale. The slider defaulted to the center point (50), and the interface displayed the numeric value of the slider position as a tooltip while the element had focus. Note that on both touch and mouse devices participants could interact with the survey element as a slider (i.e. click and and drag, or touch and drag) or as a visual analogue scale (i.e. click or tap on position along the scale).
3.10.1 FULL SCALES
The SD scores visualized here are in the same form as the participants’ response scale (slider from 0-100).
3.10.1.1 AGGREGATED
3.10.1.1.1 boxplot
#### LIST OF BLOXPLOTS + JITTER #############################################################################
# setup dataframe
df <- df_graphs
#subset data cols
cols <- df %>% select( all_of(ref_sd_questions))
plots <- as.list(lapply(colnames(cols), plot_sd, data = df, type ="S", mean=TRUE, facet = FALSE, boxplot=TRUE, labels=ref_labels))
#aggregate q plots into one for stimulus
plot_master_questions <- plots[[1]] / plots[[2]] / plots[[3]] / plots[[4]] / plots[[5]] / plots[[6]] / plots[[7]] /
plots[[8]] /plots[[9]] /plots[[10]] /plots[[11]] +
plot_annotation(
title = "ALL STIMULI",
subtitle ="", caption = "(point is mean)"
)
if(GRAPH_SAVE == TRUE){
ggsave(plot = plot_master_questions, path="figs/level_aggregated/distributions", filename =paste0("combined_stimuli","_box.png"), units = c("in"), width = 10, height = 14 )
}
print(plot_master_questions)
3.10.1.1.2 ggdist halfeye
#### GGDIST PLOT#############################################################################
# setup dataframe
df <- df_sd_questions_long %>% select(1:8, QUESTION, STIMULUS_CATEGORY, value)
d <- left_join( x = df, y = ref_labels,
by = c("QUESTION" = "ref_sd_questions")) %>%
mutate(
category=factor(category, levels=c("COMPETENCY","MAKER","CHART")),
QUESTION = factor(QUESTION, levels=ref_sd_questions)) %>%
group_by(QUESTION) %>%
mutate(m=median(value)) ## calc median for printing on graph
# GGDIST HALFEYE (raincloud doesn't work b/c long tails)
(g <- d %>%
ggplot(aes(y = fct_rev(QUESTION), x = value, fill=category)) +
stat_halfeye(scale=0.8, density="bounded", point_interval = "median_qi", normalize="xy") +
## MEDIAN
stat_summary(fun=median, geom="text", fontface = "bold", size= 2.2,
vjust=+2, hjust = 0.50, aes(label=round(m, digits=0)))+
stat_summary(fun=median, geom="point", size=2) +
scale_color_manual(values = my_palettes(name="greys", direction = "1"))+
scale_fill_manual(values = my_palettes(name="greys", direction = "1"))+
guides(
y = guide_axis_manual(labels = rev(ref_labels$left), title = ""),
y.sec = guide_axis_manual(labels = rev(ref_labels$right))
) +
cowplot::draw_text(text = ref_sd_questions, x = 90, y= ref_sd_questions,size = 8, vjust=-2) +
labs (title = "ALL STIMULI", y = "", caption = "(point is median)") +
theme_minimal() + easy_remove_legend()
)
if(GRAPH_SAVE == TRUE){
ggsave(plot = g, path="figs/level_aggregated/distributions", filename =paste0("combined_stimuli","_ggdist.png"), units = c("in"), width = 10, height = 14 )
}3.10.1.1.3 density ridges
#### DENSITY RIDGES#############################################################################
# setup dataframe
df <- df_sd_questions_long %>% select(1:8, QUESTION, value)
d <- left_join( x = df, y = ref_labels,
by = c("QUESTION" = "ref_sd_questions")) %>%
mutate(
category=factor(category, levels=c("COMPETENCY","MAKER","CHART")),
QUESTION = factor(QUESTION, levels=ref_sd_questions))%>%
group_by(QUESTION) %>%
mutate(m=median(value)) ## calc median for printing on graph
(x <-
ggplot(d, aes(x = value, y = fct_rev(QUESTION), fill = category)) +
geom_density_ridges(scale = 0.75, quantile_lines = TRUE, alpha = 0.75, panel_scaling = TRUE) +
# scale_fill_manual(values = my_palettes(name="amy_gradient", direction = "1"))+
scale_fill_manual(values = my_palettes(name="greys", direction = "1"))+
## MEDIAN
stat_summary(fun=median, geom="text", fontface = "bold", size= 2.2,
vjust=+2, hjust = 0.50, aes(label=round(m, digits=0)))+
stat_summary(fun=median, geom="point", size=2) +
# scale_x_continuous(limits = c(0,100))+
guides(
y = guide_axis_manual(labels = rev(ref_labels$left)),
y.sec = guide_axis_manual(labels = rev(ref_labels$right))
) +
labs (title = "ALL STIMULI", y = "", caption = "(point is median)") +
cowplot::draw_text(text = ref_sd_questions, x = 100, y= ref_sd_questions,size = 8, vjust=-2, position=position_nudge(y=-.20)) + ##raw
# cowplot::draw_text(text = ref_sd_questions, x = -4, y= ref_sd_questions,size = 10, vjust=-2) + ##z-score
theme_minimal() + easy_remove_legend()
)## Picking joint bandwidth of 4.51
if(GRAPH_SAVE == TRUE) {
ggsave(plot = x, path="figs/level_aggregated/distributions", filename =paste0("combined_stimuli","_ridges.png"), units = c("in"), width = 10, height = 14 )
}3.10.2 ABSOLUTE VALUES
Here the scale of the semantic differential questions have been collapsed, such that 0 is the midpoint of the scale (indicating uncertainty, or not strongly indicating either of the labelled traits) and both 100 and 0 are 50 (indicating a strong signal toward either of the labelled traits).
3.10.2.1 AGGREGATED
3.10.2.1.1 boxplot
#### LIST OF BLOXPLOTS + JITTER #############################################################################
# setup dataframe
df <- df_graphs_abs
#subset data cols
cols <- df %>% select( all_of(ref_sd_questions_abs))
plots <- as.list(lapply(colnames(cols), plot_sd, data = df, type ="S", mean=TRUE, facet = FALSE, boxplot=TRUE, labels = ref_labels_abs))
#aggregate q plots into one for stimulus
plot_master_questions <- plots[[1]] / plots[[2]] / plots[[3]] / plots[[4]] / plots[[5]] / plots[[6]] / plots[[7]] /
plots[[8]] /plots[[9]] /plots[[10]] /plots[[11]] +
plot_annotation(
title = "ALL STIMULI — SD (ABSOLUTE VALUE)",
subtitle ="", caption = "(point is mean)"
)
if(GRAPH_SAVE == TRUE){
ggsave(plot = plot_master_questions, path="figs/level_aggregated/distributions", filename =paste0("ABS_combined_stimuli","_box.png"), units = c("in"), width = 10, height = 14 )
}
print(plot_master_questions)
3.10.2.1.2 ggdist halfeye
#### GGDIST PLOT#############################################################################
# setup dataframe
df <- df_sd_questions_long_abs %>% select(1:8, QUESTION, STIMULUS_CATEGORY, value)
d <- left_join( x = df, y = ref_labels_abs,
by = c("QUESTION" = "ref_sd_questions_abs")) %>%
mutate(
category=factor(category, levels=c("COMPETENCY","MAKER","CHART")),
QUESTION = factor(QUESTION, levels=ref_sd_questions))%>%
group_by(QUESTION) %>%
mutate(m=median(value)) ## calc median for printing on graph
# GGDIST HALFEYE (raincloud doesn't work b/c long tails)
( g <- ggplot(d, aes(y = fct_rev(QUESTION), x = value, fill=category)) +
stat_halfeye(scale=0.8, density="bounded", point_interval = "median_qi", normalize="xy") +
scale_fill_manual(values = my_palettes(name="greys", direction = "1"))+
## MEDIAN
stat_summary(fun=median, geom="text", fontface = "bold", size= 2.2,
vjust=+2, hjust = 0.50, aes(label=round(m, digits=0)))+
stat_summary(fun=median, geom="point", size=2) +
guides(
y = guide_axis_manual(labels = rev(ref_labels_abs$left), title = ""),
y.sec = guide_axis_manual(labels = rev(ref_labels_abs$right))
) +
cowplot::draw_text(text = ref_sd_questions, x = 45, y= ref_sd_questions_abs,size = 8, vjust=-2) +
labs (title = "ALL STIMULI — SD (ABSOLUTE VALUE)", y = "", caption = "(point is median)") +
theme_minimal() + easy_remove_legend()
) 
if(GRAPH_SAVE == TRUE){
ggsave(plot = g, path="figs/level_aggregated/distributions", filename =paste0("ABS_combined_stimuli","_ggdist.png"), units = c("in"), width = 10, height = 14 )
}3.10.2.1.3 density ridges
#### DENSITY RIDGES#############################################################################
# setup dataframe
df <- df_sd_questions_long_abs %>% select(1:8, QUESTION, value)
d <- left_join( x = df, y = ref_labels_abs,
by = c("QUESTION" = "ref_sd_questions_abs")) %>%
mutate(
category=factor(category, levels=c("COMPETENCY","MAKER","CHART")),
QUESTION = factor(QUESTION, levels=ref_sd_questions))%>%
group_by(QUESTION) %>%
mutate(m=median(value)) ## calc median for printing on graph
( x <-ggplot(d, aes(x = value, y = fct_rev(QUESTION), fill = category)) +
geom_density_ridges(scale = 0.9,quantile_lines = TRUE, alpha = 0.75) +
# scale_fill_manual(values = my_palettes(name="amy_gradient", direction = "1"))+
scale_fill_manual(values = my_palettes(name="greys", direction = "1"))+
stat_summary(fun=median, geom="text", fontface = "bold", size= 2.2,
vjust=+2, hjust = 0.50, aes(label=round(m, digits=0)))+
stat_summary(fun=median, geom="point", size=2) +
guides(
y = guide_axis_manual(labels = rev(ref_labels_abs$left)),
y.sec = guide_axis_manual(labels = rev(ref_labels_abs$right))
) +
labs(title = "ALL STIMULI — SD (ABSOLUTE VALUE)", y = "", caption = "(point is median)") +
cowplot::draw_text(text = ref_sd_questions, x = 45, y= ref_sd_questions_abs, size = 8, vjust=-2, position=position_nudge(y=-.20)) + ##raw
theme_minimal() + easy_remove_legend()
)## Picking joint bandwidth of 2.9
if(GRAPH_SAVE == TRUE){
ggsave(plot = x, path="figs/level_aggregated/distributions", filename =paste0("ABS_combined_stimuli","_ridges.png"), units = c("in"), width = 10, height = 14 )
}rm(df, c,x,g,plot_master_questions)3.11 CORRELATIONS
3.11.1 FULL SCALE
df <- df_graphs %>%
mutate(
M_DESIGN = datawizard::standardize(MAKER_DESIGN) ,
M_DATA = datawizard::standardize(MAKER_DATA) ,
M_POLITIC = datawizard::standardize(MAKER_POLITIC) ,
M_ARGUE = datawizard::standardize(MAKER_ARGUE) ,
M_SELF = datawizard::standardize(MAKER_SELF) ,
M_ALIGN = datawizard::standardize(MAKER_ALIGN) ,
M_TRUST = datawizard::standardize(MAKER_TRUST) ,
C_TRUST = datawizard::standardize(CHART_TRUST) ,
C_INTENT = datawizard::standardize(CHART_INTENT) ,
C_LIKE = datawizard::standardize(CHART_LIKE) ,
C_BEAUTY = datawizard::standardize(CHART_BEAUTY)
) %>% select(
M_DESIGN, M_DATA, M_POLITIC, M_ARGUE, M_SELF, M_ALIGN, M_TRUST, C_TRUST, C_INTENT, C_LIKE, C_BEAUTY, PID
)
######################### FULL CORRELATION #########################
print("FULL CORRELATION WITH RANDOM EFFECT")## [1] "FULL CORRELATION WITH RANDOM EFFECT"## CALCULATE full correlations with random effects
c <- df %>% correlation(partial=FALSE, include_factors=FALSE, multilevel=TRUE)
# cor_sort(c) ## for the tiles one
(s <- c %>% summary(redundant = FALSE))## Parameter | C_BEAUTY | C_LIKE | C_INTENT | C_TRUST | M_TRUST | M_ALIGN | M_SELF | M_ARGUE | M_POLITIC | M_DATA
## ------------------------------------------------------------------------------------------------------------------------
## M_DESIGN | -0.41*** | -0.34*** | -0.04 | -0.18*** | -0.14*** | -0.08* | 0.07* | -5.53e-03 | 0.06 | 0.36***
## M_DATA | -0.18*** | -0.23*** | 0.31*** | -0.37*** | -0.31*** | -0.11*** | 0.04 | -0.10** | -0.02 |
## M_POLITIC | -0.22*** | -0.27*** | 0.11*** | -0.25*** | -0.40*** | -0.54*** | 0.57*** | -0.37*** | |
## M_ARGUE | 0.26*** | 0.30*** | -0.30*** | 0.38*** | 0.48*** | 0.42*** | -0.48*** | | |
## M_SELF | -0.35*** | -0.43*** | 0.27*** | -0.44*** | -0.58*** | -0.69*** | | | |
## M_ALIGN | 0.38*** | 0.47*** | -0.25*** | 0.49*** | 0.63*** | | | | |
## M_TRUST | 0.35*** | 0.48*** | -0.43*** | 0.69*** | | | | | |
## C_TRUST | 0.47*** | 0.59*** | -0.48*** | | | | | | |
## C_INTENT | -0.11*** | -0.20*** | | | | | | | |
## C_LIKE | 0.84*** | | | | | | | | |###### VIS WITH CORRELATION PACKAGE
#SEE [correlation] PLOT
g <- plot(s, show_text = "label",
show_data = "point",
stars=TRUE, show_legend=FALSE,
show_statistic = FALSE, show_ci = FALSE) +
theme_minimal()+
labs(title = "All Stimuli | Correlation Matrix — SD Questions",
subtitle="(full correlation; pearson method; Holm p-value adjustment; PID random effect)") + theme_minimal()
# text = list(fontface = "italic")
g
ggsave(g, scale =1, filename = "figs/level_aggregated/heatmaps/full_correlation_all_POINTS.png", width = 14, height = 6, dpi = 320, limitsize = FALSE)
######################### FULL CORRELATION #########################
print("PARTIAL CORRELATION WITH PID AS RANDOM EFFECT")## [1] "PARTIAL CORRELATION WITH PID AS RANDOM EFFECT"#CALCULATE partial correlations with PID as random effect
## (this isolates correlation pairwise factoring out other variables)
c <- df %>% correlation(partial=TRUE,multilevel = TRUE)
# cor_sort(c) ## for the tiles one
(s <- c %>% summary(redundant = FALSE ))## # Correlation Matrix (pearson-method)
##
## Parameter | C_BEAUTY | C_LIKE | C_INTENT | C_TRUST | M_TRUST | M_ALIGN | M_SELF | M_ARGUE | M_POLITIC | M_DATA
## -------------------------------------------------------------------------------------------------------------------------
## M_DESIGN | -0.26*** | 8.55e-03 | -0.16*** | 0.04 | -0.04 | 0.07 | 0.01 | 0.08* | 0.04 | 0.35***
## M_DATA | 0.08* | -0.04 | 0.20*** | -0.15*** | -0.13*** | 3.78e-03 | -0.13*** | 0.01 | -0.06 |
## M_POLITIC | 0.02 | -6.67e-03 | -0.06 | 0.06 | -0.05 | -0.23*** | 0.28*** | -0.11*** | |
## M_ARGUE | 0.07 | -0.03 | -0.11*** | 0.03 | 0.16*** | 7.90e-03 | -0.17*** | | |
## M_SELF | -0.03 | -0.04 | 0.07 | -2.17e-03 | -0.16*** | -0.36*** | | | |
## M_ALIGN | 3.74e-03 | 0.10** | 0.04 | 0.04 | 0.25*** | | | | |
## M_TRUST | -0.08* | 0.05 | -0.10** | 0.39*** | | | | | |
## C_TRUST | 0.04 | 0.23*** | -0.27*** | | | | | | |
## C_INTENT | 0.05 | 0.03 | | | | | | | |
## C_LIKE | 0.74*** | | | | | | | | |
##
## p-value adjustment method: Holm (1979)###### VIS WITH CORRELATION PACKAGE
#SEE [correlation] PLOT
g <- plot(s, show_text = "label",
show_data = "point",
stars=TRUE, show_legend=FALSE,
show_statistic = FALSE, show_ci = FALSE) +
theme_minimal()+
labs(title = "All Stimuli | Correlation Matrix — SD Questions",
subtitle="(partial correlation; pearson method; Holm p-value adjustment; participant as random effect)")
# text = list(fontface = "italic")
g
ggsave(g, scale =1, filename = "figs/level_aggregated/heatmaps/partial_correlation_all_POINTS.png", width = 14, height = 6, dpi = 320, limitsize = FALSE)
###### VIS WITH CORRPLOT <- -- customizable but can't save to file ARGH
#
# ## GET THE MATRIX
# m <- as.matrix(c)
#
#
# ## JUST CIRCLES
# corrplot(m, method = 'circle', type = 'lower',
# order = 'original', diag = FALSE, addCoef.col = "#7A7A7A",
# tl.col = "black")
##############################################################################These plots depict the PARTIAL CORRELATION pairwise between variables (partial correlation factors out influence of other variables), with participant ID as a random effect. The resulting values are pearson moment-correlation coefficients ranging of -1 (direct negative) to +1 direct positive correlation. These correlations are calculated on the full scale semantic differential questions (i.e. with the 0 - 100 range, where 1 and 100 are end points and 50 is the central point)
3.11.1.1 node-link diagram
###################PLOT GAUSSIAN GRAPH MODEL
## get only significant correlations
m <- c # the correlation matrix
## default from easystats
# plot(m)
## 1 SIMPLY NODE NAMES
m <- as_tibble(c) %>%
mutate(
Parameter1 = str_replace_all(Parameter1, "MAKER_", "M_"),
Parameter1 = str_replace_all(Parameter1, "CHART_", "C_"),
Parameter2 = str_replace_all(Parameter2, "MAKER_", "M_"),
Parameter2 = str_replace_all(Parameter2, "CHART_", "C_")
)
## 2 SHOW ONLY SIGNIFICANT CORRELATIONS
m <- m %>%
filter(p <= 0.05)
## 3 FORMAT AS GRAPH
g <- as_tbl_graph(m)
### Gaussian Graphical Models (GGMs)
# Bhushan et al., 2019
# https://www.frontiersin.org/journals/psychology/articles/10.3389/fpsyg.2019.01050/full
f <-
ggraph(g, layout = 'stress') +
# ggraph(g, layout = 'linear', circular = TRUE) +
geom_edge_link(aes(colour =r,
edge_width = r,
label = round(r,2))) +
geom_node_point( size = 5) +
geom_node_label(size = 3,
# vjust = +1,
# hjust = 0.5,
repel = TRUE,
aes(label = name)) +
scale_edge_color_gradient2(low = "red",
mid = "white",
high = "blue",
midpoint = 0,
space = "Lab",
# na.value = "grey50",
guide = "edge_colourbar",
aesthetics = "edge_colour") +
theme_graph() + labs(title = "All Stimuli | Significant Partial Correlations (full SD scale)")
f 
3.11.2 ABSOLUTE VALUES
df <- df_graphs_abs %>%
mutate(
M_DESIGN = datawizard::standardize(MAKER_DESIGN) ,
M_DATA = datawizard::standardize(MAKER_DATA) ,
M_POLITIC = datawizard::standardize(MAKER_POLITIC) ,
M_ARGUE = datawizard::standardize(MAKER_ARGUE) ,
M_SELF = datawizard::standardize(MAKER_SELF) ,
M_ALIGN = datawizard::standardize(MAKER_ALIGN) ,
M_TRUST = datawizard::standardize(MAKER_TRUST) ,
C_TRUST = datawizard::standardize(CHART_TRUST) ,
C_INTENT = datawizard::standardize(CHART_INTENT) ,
C_LIKE = datawizard::standardize(CHART_LIKE) ,
C_BEAUTY = datawizard::standardize(CHART_BEAUTY)
) %>% select(
M_DESIGN, M_DATA, M_POLITIC, M_ARGUE, M_SELF, M_ALIGN, M_TRUST, C_TRUST, C_INTENT, C_LIKE, C_BEAUTY, PID
)
######################### FULL CORRELATION #########################
print("FULL CORRELATION NO RANDOM EFFECT")## [1] "FULL CORRELATION NO RANDOM EFFECT"## CALCULATE full correlations with no random effects
c <- df %>% correlation(partial=FALSE, multilevel=TRUE)
# cor_sort(c) ## for the tiles one
(s <- c %>% summary(redundant = FALSE))## Parameter | C_BEAUTY | C_LIKE | C_INTENT | C_TRUST | M_TRUST | M_ALIGN | M_SELF | M_ARGUE | M_POLITIC | M_DATA
## -----------------------------------------------------------------------------------------------------------------
## M_DESIGN | 0.20*** | 0.21*** | 0.04 | 0.14*** | 0.11*** | 0.08** | 0.11*** | 0.11*** | 0.08** | 0.34***
## M_DATA | 0.13*** | 0.13*** | 0.20*** | 0.20*** | 0.16*** | 0.03 | 0.08** | 0.12*** | 2.66e-03 |
## M_POLITIC | 0.10*** | 0.16*** | 0.04 | 0.16*** | 0.23*** | 0.54*** | 0.49*** | 0.40*** | |
## M_ARGUE | 0.12*** | 0.15*** | 0.16*** | 0.24*** | 0.36*** | 0.41*** | 0.47*** | | |
## M_SELF | 0.11*** | 0.18*** | 0.13*** | 0.21*** | 0.40*** | 0.58*** | | | |
## M_ALIGN | 0.15*** | 0.23*** | 0.15*** | 0.30*** | 0.44*** | | | | |
## M_TRUST | 0.09** | 0.19*** | 0.26*** | 0.51*** | | | | | |
## C_TRUST | 0.30*** | 0.40*** | 0.33*** | | | | | | |
## C_INTENT | 0.09** | 0.13*** | | | | | | | |
## C_LIKE | 0.67*** | | | | | | | | |g <- plot(s, show_text = "label",
# show_data = "point",
stars=TRUE, show_legend=FALSE,
show_statistic = FALSE, show_ci = FALSE) +
theme_minimal()+
labs(title = "All Stimuli | Correlation Matrix — SD Questions — ABSOLUTE VALUES",
subtitle="(full correlation; pearson method; Holm p-value adjustment; PID random effect)") + theme_minimal()
# text = list(fontface = "italic")
g
ggsave(g, scale =1, filename = "figs/level_aggregated/heatmaps/ABS_full_correlation_all_POINTS.png", width = 14, height = 6, dpi = 320, limitsize = FALSE)
######################### PARTIAL CORRELATION #########################
print("PARTIAL CORRELATION WITH PID AS RANDOM EFFECT")## [1] "PARTIAL CORRELATION WITH PID AS RANDOM EFFECT"#CALCULATE partial correlations with PID as random effect
## (this isolates correlation pairwise factoring out other variables)
c <- df %>% correlation(partial=TRUE, multilevel = TRUE)
# cor_sort(c) ## for the tiles one
(s <- c %>% summary(redundant = FALSE ))## # Correlation Matrix (pearson-method)
##
## Parameter | C_BEAUTY | C_LIKE | C_INTENT | C_TRUST | M_TRUST | M_ALIGN | M_SELF | M_ARGUE | M_POLITIC | M_DATA
## ----------------------------------------------------------------------------------------------------------------------
## M_DESIGN | 0.08 | 0.07 | -0.06 | -2.84e-03 | 0.02 | -0.02 | 0.03 | 0.03 | 0.03 | 0.31***
## M_DATA | 0.02 | -1.43e-03 | 0.15*** | 0.07 | 0.05 | -0.07 | 0.03 | 0.05 | -0.04 |
## M_POLITIC | -0.02 | 0.03 | -0.07 | 0.01 | -0.08 | 0.33*** | 0.21*** | 0.19*** | |
## M_ARGUE | 0.03 | -0.02 | 0.06 | 0.03 | 0.13*** | 0.07 | 0.22*** | | |
## M_SELF | -9.25e-03 | 0.04 | 0.01 | -0.07 | 0.16*** | 0.32*** | | | |
## M_ALIGN | 0.02 | 0.06 | 0.03 | 0.05 | 0.22*** | | | | |
## M_TRUST | -0.08* | -0.02 | 0.07 | 0.39*** | | | | | |
## C_TRUST | 0.07 | 0.22*** | 0.20*** | | | | | | |
## C_INTENT | -9.03e-03 | 5.23e-03 | | | | | | | |
## C_LIKE | 0.61*** | | | | | | | | |
##
## p-value adjustment method: Holm (1979)###### VIS WITH CORRELATION PACKAGE
#SEE [correlation] PLOT
g <- plot(s, show_text = "label",
# show_data = "point",
stars=TRUE, show_legend=FALSE,
show_statistic = FALSE, show_ci = FALSE) +
theme_minimal()+
labs(title = "All Stimuli | Correlation Matrix — SD Questions — ABSOLUTE VALUES",
subtitle="(partial correlation; pearson method; Holm p-value adjustment; participant as random effect)")
# text = list(fontface = "italic")
g
ggsave(g, scale =1, filename = "figs/level_aggregated/heatmaps/ABS_partial_correlation_all_POINTS.png", width = 14, height = 6, dpi = 320, limitsize = FALSE)
#PLOT GAUSSIAN GRAPH MODEL
# plot(c)
###### VIS WITH CORRPLOT <- -- customizable but can't save to file ARGH
## GET THE MATRIX
m <- as.matrix(c)
## JUST CIRCLES
corrplot(m, method = 'circle', type = 'lower',
order = 'original', diag = FALSE, addCoef.col = "#7A7A7A",
tl.col = "black")
INTERPRETATION These plots depict the PARTIAL CORRELATION pairwise between variables (partial correlation factors out influence of other variables), with participant ID as a random effect. The resulting values are pearson moment-correlation coefficients ranging of -1 (direct negative) to +1 direct positive correlation. These correlations are calculated on the ABSOLUTE VALUE of the semantic differential questions (i.e. with the full scale folded in half, such that 50 now becomes 0, and the extrememe values (0, 100) become 50). The absolute value scale allows us to collapse for weak (near zero) vs. strong (near 50) signal in each variable.
3.11.3 correlation matrices — by category levels
Here we explore the distribution of each SD variable (e.g. MAKER TRUST) by the different values of each categorical variable (e.g. MAKER ID). Patterns of interest are noted, which we explore further in the section exploratory questions.
3.11.3.0.1 MAKER ID X SD
df <- df_graphs %>% select(MAKER_DESIGN, MAKER_DATA,
MAKER_POLITIC, MAKER_ARGUE, MAKER_SELF, MAKER_ALIGN, MAKER_TRUST,
CHART_TRUST, CHART_INTENT, CHART_LIKE, CHART_BEAUTY,
PID, STIMULUS, BLOCK, STIMULUS_CATEGORY,
MAKER_ID, MAKER_AGE, MAKER_GENDER)
## CORRELATION MATRIX SPLIT BY MAKER ID
(x <- ggscatmat(df, columns = 1:11, color = "MAKER_ID", alpha = 0.8) +
scale_color_manual(values = my_palettes(name="reds", direction = "1"), name = "", guide = guide_legend(reverse = FALSE)) +
theme_minimal()
)
if(GRAPH_SAVE){
ggsave(plot = x, path="figs/level_aggregated/pairplots", filename =paste0("maker_id_corr_sd.png"), units = c("in"), width = 14, height = 10 )
}
x
Interesting patterns to explore further
- When participants identify the maker as an INDIVIDUAL, the following variables show a different pattern than the other identifications: MAKER_DESIGN, MAKER_DATA, CHART INTENT
- interesting bimodal distribution on CHART INTENT for most identifications, except individuals and organizations
3.11.3.0.2 MAKER ID X SD (abs)
df <- df_graphs_abs %>% select(MAKER_DESIGN, MAKER_DATA,
MAKER_POLITIC, MAKER_ARGUE, MAKER_SELF, MAKER_ALIGN, MAKER_TRUST,
CHART_TRUST, CHART_INTENT, CHART_LIKE, CHART_BEAUTY,
PID, STIMULUS, BLOCK, STIMULUS_CATEGORY,
MAKER_ID, MAKER_AGE, MAKER_GENDER)
## CORRELATION MATRIX SPLIT BY MAKER ID
(x <- ggscatmat(df, columns = 1:11, color = "MAKER_ID", alpha = 0.8) +
scale_color_manual(values = my_palettes(name="reds", direction = "1"), name = "", guide = guide_legend(reverse = FALSE)) +
theme_minimal())
if(GRAPH_SAVE){
ggsave(plot = x, path="figs/level_aggregated/pairplots", filename =paste0("maker_id_corr_abs.png"), units = c("in"), width = 14, height = 10 )
}
x
3.11.3.0.3 MAKER AGE X SD
df <- df_graphs %>% select(MAKER_DESIGN, MAKER_DATA,
MAKER_POLITIC, MAKER_ARGUE, MAKER_SELF, MAKER_ALIGN, MAKER_TRUST,
CHART_TRUST, CHART_INTENT, CHART_LIKE, CHART_BEAUTY,
PID, STIMULUS, BLOCK, STIMULUS_CATEGORY,
MAKER_ID, MAKER_AGE, MAKER_GENDER)
## CORRELATION MATRIX SPLIT BY MAKER AGE
(x <- ggscatmat(df, columns = 1:11, color = "MAKER_AGE", alpha = 0.8) +
scale_color_manual(values = my_palettes(name="lightblues", direction = "1"), name = "", guide = guide_legend(reverse = TRUE)) +
theme_minimal())
if(GRAPH_SAVE){
ggsave(plot = x, path="figs/level_aggregated/pairplots", filename =paste0("maker_age_corr_sd.png"), units = c("in"), width = 14, height = 10 )
}
x
Interesting patterns to explore further
- maker_design, chart_like, chart_beauty for BOOMER vs. others
- maker_data for gen Z vs others
3.11.3.0.4 MAKER AGE X SD (abs)
df <- df_graphs_abs %>% select(MAKER_DESIGN, MAKER_DATA,
MAKER_POLITIC, MAKER_ARGUE, MAKER_SELF, MAKER_ALIGN, MAKER_TRUST,
CHART_TRUST, CHART_INTENT, CHART_LIKE, CHART_BEAUTY,
PID, STIMULUS, BLOCK, STIMULUS_CATEGORY,
MAKER_ID, MAKER_AGE, MAKER_GENDER)
## CORRELATION MATRIX SPLIT BY MAKER AGE
(x <- ggscatmat(df, columns = 1:11, color = "MAKER_AGE", alpha = 0.8) +
scale_color_manual(values = my_palettes(name="lightblues", direction = "1"), name = "", guide = guide_legend(reverse = TRUE)) +
theme_minimal())
if(GRAPH_SAVE){
ggsave(plot = x, path="figs/level_aggregated/pairplots", filename =paste0("maker_age_corr_abs.png"), units = c("in"), width = 14, height = 10 )
}
x
3.11.3.0.5 MAKER GENDER X SD
df <- df_graphs %>% select(MAKER_DESIGN, MAKER_DATA,
MAKER_POLITIC, MAKER_ARGUE, MAKER_SELF, MAKER_ALIGN, MAKER_TRUST,
CHART_TRUST, CHART_INTENT, CHART_LIKE, CHART_BEAUTY,
PID, STIMULUS, BLOCK, STIMULUS_CATEGORY,
MAKER_ID, MAKER_AGE, MAKER_GENDER)
## CORRELATION MATRIX SPLIT BY MAKER GENDER
(x <- ggscatmat(df, columns = 1:11, color = "MAKER_GENDER", alpha = 0.8) +
scale_color_manual(values = my_palettes(name="smallgreens", direction = "1"), name = "", guide = guide_legend(reverse = TRUE)) +
theme_minimal() )
if(GRAPH_SAVE){
ggsave(plot = x, path="figs/level_aggregated/pairplots", filename =paste0("maker_gender_corr_sd.png"), units = c("in"), width = 14, height = 10 )
}
x
Interesting patterns to explore further - maker-data for FEMALE
3.11.3.0.6 MAKER GENDER X SD (abs)
df <- df_graphs_abs %>% select(MAKER_DESIGN, MAKER_DATA,
MAKER_POLITIC, MAKER_ARGUE, MAKER_SELF, MAKER_ALIGN, MAKER_TRUST,
CHART_TRUST, CHART_INTENT, CHART_LIKE, CHART_BEAUTY,
PID, STIMULUS, BLOCK, STIMULUS_CATEGORY,
MAKER_ID, MAKER_AGE, MAKER_GENDER)
## CORRELATION MATRIX SPLIT BY MAKER GENDER
(x <- ggscatmat(df, columns = 1:11, color = "MAKER_GENDER", alpha = 0.8) +
scale_color_manual(values = my_palettes(name="smallgreens", direction = "1"), name = "", guide = guide_legend(reverse = TRUE)) +
theme_minimal() )
if(GRAPH_SAVE){
ggsave(plot = x, path="figs/level_aggregated/pairplots", filename =paste0("maker_gender_corr_abs.png"), units = c("in"), width = 14, height = 10 )
}
x
3.11.3.0.7 TOOL ID X SD
df <- df_tools %>% select(MAKER_DESIGN, MAKER_DATA,
MAKER_POLITIC, MAKER_ARGUE, MAKER_SELF, MAKER_ALIGN, MAKER_TRUST,
CHART_TRUST, CHART_INTENT, CHART_LIKE, CHART_BEAUTY,
PID, STIMULUS, BLOCK, STIMULUS_CATEGORY,
TOOL_ID)
## CORRELATION MATRIX SPLIT BY TOOL ID
(x <- ggscatmat(df, columns = 1:11, color = "TOOL_ID", alpha = 0.8) +
scale_color_manual(values = my_palettes(name="tools", direction = "1"), name = "", guide = guide_legend(reverse = TRUE)) +
theme_minimal() )
if(GRAPH_SAVE){
ggsave(plot = x, path="figs/level_aggregated/pairplots", filename =paste0("tool_id_corr_sd.png"), units = c("in"), width = 14, height = 10 )
}
x
Interesting patterns to explore further - maker data for design-basic, interesting pattern - look closer at chart beauty - interesting pattern across values on chart intent
3.11.3.0.8 ENCOUNTER X SD
df <- df_graphs %>% select(MAKER_DESIGN, MAKER_DATA,
MAKER_POLITIC, MAKER_ARGUE, MAKER_SELF, MAKER_ALIGN, MAKER_TRUST,
CHART_TRUST, CHART_INTENT, CHART_LIKE, CHART_BEAUTY,
PID, STIMULUS, BLOCK, STIMULUS_CATEGORY,
ENCOUNTER) %>%
mutate(ENCOUNTER = fct_rev(ENCOUNTER))
## CORRELATION MATRIX SPLIT BY ENCOUNTER
(x <- ggscatmat(df, columns = 1:11, color = "ENCOUNTER", alpha = 0.8) +
scale_color_manual(values = my_palettes(name="encounter", direction = "1"))+
theme_minimal())
if(GRAPH_SAVE){
ggsave(plot = x, path="figs/level_aggregated/pairplots", filename =paste0("encounter_corr_sd.png"), units = c("in"), width = 14, height = 10 )
}
x
Interesting patterns to explore further — no difference at ALL in maker data - interesting! - chart beauty very diff - chart intent intersting bimodal
3.11.3.0.9 ENCOUNTER X SD (abs)
df <- df_graphs_abs %>% select(MAKER_DESIGN, MAKER_DATA,
MAKER_POLITIC, MAKER_ARGUE, MAKER_SELF, MAKER_ALIGN, MAKER_TRUST,
CHART_TRUST, CHART_INTENT, CHART_LIKE, CHART_BEAUTY,
PID, STIMULUS, BLOCK, STIMULUS_CATEGORY,
ENCOUNTER) %>%
mutate(ENCOUNTER = fct_rev(ENCOUNTER))
## CORRELATION MATRIX SPLIT BY ENCOUNTER
(x <- ggscatmat(df, columns = 1:11, color = "ENCOUNTER", alpha = 0.8) +
scale_color_manual(values = my_palettes(name="encounter", direction = "1"))+
theme_minimal())
if(GRAPH_SAVE){
ggsave(plot = x, path="figs/level_aggregated/pairplots", filename =paste0("encounter_corr_abs.png"), units = c("in"), width = 14, height = 10 )
}
x
3.11.3.0.10 CHART ACTION X SD
df <- df_actions %>% select(MAKER_DESIGN, MAKER_DATA,
MAKER_POLITIC, MAKER_ARGUE, MAKER_SELF, MAKER_ALIGN, MAKER_TRUST,
CHART_TRUST, CHART_INTENT, CHART_LIKE, CHART_BEAUTY,
PID, STIMULUS, BLOCK, STIMULUS_CATEGORY,
CHART_ACTION)
## CORRELATION MATRIX SPLIT BY CHART ACTION
(x <- ggscatmat(df, columns = 1:11, color = "CHART_ACTION", alpha = 0.2) +
scale_color_manual(values = my_palettes(name="actions", direction = "1"), name = "", guide = guide_legend(reverse = TRUE)) +
theme_minimal() )
if(GRAPH_SAVE){
ggsave(plot = x, path="figs/level_aggregated/pairplots", filename =paste0("chart_action_corr_sd.png"), units = c("in"), width = 14, height = 10 )
}
x
Interesting patterns to explore further - unfollow/block across all!
4 !!!! TOP PRIORITY HYPOTHESIS TESTING !!!
DONE - Beauty !== Trust, 2. Some individual visualizations have higher confidence, and some have lower (indexical richness), 3. Beauty + Trust = engagement, but Beauty + Untrust = less engagement (SEE ENCOUNTER MODELLING IN CATEGORY LEVEL FILE )
4.1 PREDICTING TRUST
What predicts TRUST? Recent work in psychology suggests that beauty predicts trust. However, from our free response data, we think that some aesthetically pleasing images are interpreted as persuasive and thus less trustworthy. On this basis, we predict that there will be a significant interaction between BEAUTY and INTENT
4.1.0.1 visualize
df <- df_graphs %>%
## FILTER OUT B0-0 COMMON STIMULUS (so cells can be balanced)
# filter(STIMULUS != "B0-0") %>%
select(PID, STIMULUS, STIMULUS_CATEGORY, BLOCK, ENCOUNTER, CHART_TRUST, CHART_BEAUTY, CHART_INTENT, MAKER_TRUST, MAKER_DATA, MAKER_ID) %>%
mutate(
## (only used if not filtering out B0-0)
## RECODE #recode b00 graph as category D [bc it fits in that category]
# STIMULUS_CATEGORY = fct_recode(STIMULUS_CATEGORY, D="F")
) %>% droplevels()
df %>% ggplot(aes(x=CHART_BEAUTY, y=CHART_TRUST, color = CHART_INTENT)) +
geom_point() +
stat_smooth(method = "lm", formula = y ~ x, geom = "smooth") +
facet_wrap(~MAKER_ID)+
labs(title = "CHART TRUST BY BEAUTY & INTENT") +
theme_minimal()
df %>% ggplot(aes(x=CHART_INTENT, y=CHART_TRUST, color = CHART_BEAUTY)) +
geom_point() +
facet_wrap(~MAKER_ID)+
stat_smooth(method = "lm", formula = y ~ x, geom = "smooth") +
labs(title = "CHART TRUST BY INTENT & BEAUTY")+
theme_minimal()
df %>% ggplot(aes(x=MAKER_DATA, y=CHART_TRUST, color = CHART_BEAUTY)) +
geom_point() +
facet_wrap(~MAKER_ID)+
stat_smooth(method = "lm", formula = y ~ x, geom = "smooth") +
labs(title = "CHART TRUST BY INTENT & BEAUTY")+
theme_minimal()
df %>% ggplot(aes(x=MAKER_ID, y=CHART_TRUST, color = CHART_BEAUTY)) +
# geom_point() +
geom_boxplot() + geom_point(position=position_jitter(width = 0.2))+
# stat_smooth(method = "lm", formula = y ~ x, geom = "smooth") +
labs(title = "CHART TRUST BY INTENT & BEAUTY")+
theme_minimal()
4.1.0.2 MODEL
Is BEAUTY or INTENT a better predictor of TRUST? Here we fit a series
of linear mixed effects models, predicting CHART_TRUST by
CHART_BEAUTY and CHART_INTENT
4.1.0.2.1 SETUP DATA
df <- df_graphs %>%
## FILTER OUT B0-0 COMMON STIMULUS (so cells can be balanced)
# filter(STIMULUS != "B0-0") %>%
select(PID, STIMULUS,STIMULUS_CATEGORY, MAKER_ID, MAKER_TRUST, CHART_TRUST, CHART_BEAUTY, CHART_INTENT, MAKER_DATA) %>%
mutate(
TRUST_Z = datawizard::standardise(CHART_TRUST),
BEAUTY_Z = datawizard::standardise(CHART_BEAUTY),
INTENT_Z = datawizard::standardise(CHART_INTENT),
DATA_Z = datawizard::standardise(MAKER_DATA),
r_MAKER_DATA = datawizard::reverse(MAKER_DATA), # reverse b/c 0 = professional, 100=layperson
r_DATA_Z = datawizard::standardise(r_MAKER_DATA)
) %>%
droplevels()
################## BUILD MODELS #################
# # RANDOM INTERCEPT SUBJECT
# mm.rP <- lmer(CHART_TRUST ~ (1|PID), data = df)
# print("random effect only")
# summary(mm.rP)4.1.0.2.2 TRUST ~ BEAUTY
################## TRUST ~ BEAUTY #################
f.B <- "TRUST ~ BEAUTY + (1|PID)"
print("TRUSTS ~ BEAUTY + (1|PID)")## [1] "TRUSTS ~ BEAUTY + (1|PID)"mm.B <- lmer(TRUST_Z ~ BEAUTY_Z + (1|PID), data = df)
car::Anova(mm.B, type=2)## Analysis of Deviance Table (Type II Wald chisquare tests)
##
## Response: TRUST_Z
## Chisq Df Pr(>Chisq)
## BEAUTY_Z 466.15 1 < 0.00000000000000022 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(mm.B)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: TRUST_Z ~ BEAUTY_Z + (1 | PID)
## Data: df
##
## REML criterion at convergence: 4080.9
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.1757 -0.5786 0.0290 0.6335 3.3039
##
## Random effects:
## Groups Name Variance Std.Dev.
## PID (Intercept) 0.07997 0.2828
## Residual 0.69191 0.8318
## Number of obs: 1590, groups: PID, 318
##
## Fixed effects:
## Estimate Std. Error
## (Intercept) 0.0000000000000001043 0.0262038949302646103
## BEAUTY_Z 0.4684975947873575852 0.0216992510912086545
## df t value Pr(>|t|)
## (Intercept) 315.5142961825368388418 0.00 1
## BEAUTY_Z 1554.1949792186439935904 21.59 <0.0000000000000002 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr)
## BEAUTY_Z 0.000performance(mm.B)## # Indices of model performance
##
## AIC | AICc | BIC | R2 (cond.) | R2 (marg.) | ICC | RMSE | Sigma
## --------------------------------------------------------------------------------
## 4088.943 | 4088.968 | 4110.429 | 0.302 | 0.221 | 0.104 | 0.800 | 0.832## REPORT
# report(mm.B)
## PLOT
plot_model(mm.B, type = "eff", terms = "BEAUTY_Z") +
labs(subtitle = f.B) + theme_minimal()
## IN PAPER4.1.0.2.3 TRUST ~ INTENT
################## TRUST ~ INTEN #################
f.I <- "TRUST ~ INTENT + (1|PID)"
mm.I <- lmer(TRUST_Z ~ INTENT_Z + (1|PID), data = df)
car::Anova(mm.I, type=2)## Analysis of Deviance Table (Type II Wald chisquare tests)
##
## Response: TRUST_Z
## Chisq Df Pr(>Chisq)
## INTENT_Z 500.89 1 < 0.00000000000000022 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(mm.I)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: TRUST_Z ~ INTENT_Z + (1 | PID)
## Data: df
##
## REML criterion at convergence: 4057.1
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.3435 -0.5839 0.0374 0.6150 3.0042
##
## Random effects:
## Groups Name Variance Std.Dev.
## PID (Intercept) 0.1178 0.3432
## Residual 0.6571 0.8106
## Number of obs: 1590, groups: PID, 318
##
## Fixed effects:
## Estimate Std. Error
## (Intercept) 0.0000000000000001386 0.0279930450211499579
## INTENT_Z -0.4884664653976160120 0.0218255342463734188
## df t value Pr(>|t|)
## (Intercept) 315.8005194695463728749 0.00 1
## INTENT_Z 1579.0829226386761092726 -22.38 <0.0000000000000002 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr)
## INTENT_Z 0.000performance(mm.I)## # Indices of model performance
##
## AIC | AICc | BIC | R2 (cond.) | R2 (marg.) | ICC | RMSE | Sigma
## --------------------------------------------------------------------------------
## 4065.118 | 4065.143 | 4086.604 | 0.352 | 0.235 | 0.152 | 0.771 | 0.811## REPORT
# report(mm.I)
## PLOT
plot_model(mm.I, type = "pred", terms = "INTENT_Z") +
labs(subtitle = f.I) + theme_minimal()
## IN PAPER
tab_model(mm.I)| TRUST Z | |||
|---|---|---|---|
| Predictors | Estimates | CI | p |
| (Intercept) | 0.00 | -0.05 – 0.05 | 1.000 |
| INTENT Z | -0.49 | -0.53 – -0.45 | <0.001 |
| Random Effects | |||
| σ2 | 0.66 | ||
| τ00 PID | 0.12 | ||
| ICC | 0.15 | ||
| N PID | 318 | ||
| Observations | 1590 | ||
| Marginal R2 / Conditional R2 | 0.235 / 0.352 | ||
4.1.0.2.4 TRUST ~ DATA !!COMPETING!!
################## TRUST ~ DATA #################
f.D <- "TRUST ~ DATA + (1|PID)"
mm.D <- lmer(TRUST_Z ~ DATA_Z + (1|PID), data = df)
car::Anova(mm.D, type=2)## Analysis of Deviance Table (Type II Wald chisquare tests)
##
## Response: TRUST_Z
## Chisq Df Pr(>Chisq)
## DATA_Z 295.63 1 < 0.00000000000000022 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(mm.D)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: TRUST_Z ~ DATA_Z + (1 | PID)
## Data: df
##
## REML criterion at convergence: 4218.8
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.0953 -0.5722 0.1125 0.6645 3.2844
##
## Random effects:
## Groups Name Variance Std.Dev.
## PID (Intercept) 0.1058 0.3252
## Residual 0.7425 0.8617
## Number of obs: 1590, groups: PID, 318
##
## Fixed effects:
## Estimate Std. Error
## (Intercept) 0.0000000000000001547 0.0282764791473604088
## DATA_Z -0.3929952189459485767 0.0228565523821661655
## df t value Pr(>|t|)
## (Intercept) 316.9184121730313563603 0.00 1
## DATA_Z 1576.7660123234265938663 -17.19 <0.0000000000000002 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr)
## DATA_Z 0.000performance(mm.D)## # Indices of model performance
##
## AIC | AICc | BIC | R2 (cond.) | R2 (marg.) | ICC | RMSE | Sigma
## --------------------------------------------------------------------------------
## 4226.781 | 4226.806 | 4248.267 | 0.260 | 0.154 | 0.125 | 0.825 | 0.862## REPORT
# report(mm.I)
## PLOT
plot_model(mm.D, type = "pred", terms = "DATA_Z") +
labs(subtitle = f.D) + theme_minimal()
##### TRUST ~ MAKER_ID
################## TRUST ~ MAKER #################
f.M <- "TRUST ~ MAKER + (1|PID)"
mm.M <- lmer(TRUST_Z ~ MAKER_ID + (1|PID), data = df)
car::Anova(mm.M, type=2)## Analysis of Deviance Table (Type II Wald chisquare tests)
##
## Response: TRUST_Z
## Chisq Df Pr(>Chisq)
## MAKER_ID 128.65 5 < 0.00000000000000022 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(mm.M)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: TRUST_Z ~ MAKER_ID + (1 | PID)
## Data: df
##
## REML criterion at convergence: 4377.5
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -2.8094 -0.5260 0.1000 0.6538 2.5499
##
## Random effects:
## Groups Name Variance Std.Dev.
## PID (Intercept) 0.119 0.3449
## Residual 0.815 0.9028
## Number of obs: 1590, groups: PID, 318
##
## Fixed effects:
## Estimate Std. Error df t value
## (Intercept) -0.44729 0.06941 1513.09401 -6.444
## MAKER_IDorganization 0.37780 0.11368 1536.77348 3.323
## MAKER_IDeducation 0.78971 0.08129 1486.64198 9.715
## MAKER_IDbusiness 0.40978 0.08509 1529.15057 4.816
## MAKER_IDnews 0.58312 0.08564 1519.91513 6.809
## MAKER_IDpolitical 0.17542 0.08923 1533.07416 1.966
## Pr(>|t|)
## (Intercept) 0.0000000001560 ***
## MAKER_IDorganization 0.00091 ***
## MAKER_IDeducation < 0.0000000000000002 ***
## MAKER_IDbusiness 0.0000016110301 ***
## MAKER_IDnews 0.0000000000141 ***
## MAKER_IDpolitical 0.04949 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) MAKER_IDr MAKER_IDd MAKER_IDb MAKER_IDn
## MAKER_IDrgn -0.571
## MAKER_IDdct -0.789 0.482
## MAKER_IDbsn -0.764 0.469 0.648
## MAKER_IDnws -0.757 0.464 0.643 0.622
## MAKER_IDplt -0.728 0.444 0.617 0.601 0.593performance(mm.M)## # Indices of model performance
##
## AIC | AICc | BIC | R2 (cond.) | R2 (marg.) | ICC | RMSE | Sigma
## --------------------------------------------------------------------------------
## 4393.501 | 4393.592 | 4436.473 | 0.189 | 0.070 | 0.127 | 0.862 | 0.903## REPORT
# report(mm.M)
## PLOT
plot_model(mm.M, type = "pred", terms = "MAKER_ID") +
labs(subtitle = f.M) + theme_minimal()
4.1.0.2.5 compare
compare_performance(mm.B, mm.I, mm.D, rank = TRUE)## # Comparison of Model Performance Indices
##
## Name | Model | R2 (cond.) | R2 (marg.) | ICC | RMSE | Sigma | AIC weights | AICc weights | BIC weights | Performance-Score
## ---------------------------------------------------------------------------------------------------------------------------------------
## mm.I | lmerModLmerTest | 0.352 | 0.235 | 0.152 | 0.771 | 0.811 | 1.000 | 1.000 | 1.000 | 100.00%
## mm.B | lmerModLmerTest | 0.302 | 0.221 | 0.104 | 0.800 | 0.832 | 7.20e-06 | 7.20e-06 | 7.20e-06 | 29.08%
## mm.D | lmerModLmerTest | 0.260 | 0.154 | 0.125 | 0.825 | 0.862 | 7.43e-36 | 7.43e-36 | 7.43e-36 | 5.45%anova(mm.B, mm.I, mm.D)## refitting model(s) with ML (instead of REML)## Data: df
## Models:
## mm.B: TRUST_Z ~ BEAUTY_Z + (1 | PID)
## mm.I: TRUST_Z ~ INTENT_Z + (1 | PID)
## mm.D: TRUST_Z ~ DATA_Z + (1 | PID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mm.B 4 4077.7 4099.2 -2034.8 4069.7
## mm.I 4 4054.0 4075.5 -2023.0 4046.0 23.682 0
## mm.D 4 4215.8 4237.3 -2103.9 4207.8 0.000 04.1.0.2.6 TRUST ~ BEAUTY X INTENT
## ADD IXN EFFECT
################## TRUST ~ BEAUTY X INTENT #################
f.BxI <- "TRUST ~ BEAUTY X INTENT + (1|PID)"
print("TRUST ~ BEAUTY X INTENT + (1|PID)")## [1] "TRUST ~ BEAUTY X INTENT + (1|PID)"mm.BxI <- lmer(TRUST_Z ~ INTENT_Z * BEAUTY_Z + (1|PID), data = df, REML=FALSE)
compare_performance(mm.BxI, mm.B, mm.I, rank = TRUE)## # Comparison of Model Performance Indices
##
## Name | Model | R2 (cond.) | R2 (marg.) | ICC | RMSE | Sigma | AIC weights | AICc weights | BIC weights | Performance-Score
## -----------------------------------------------------------------------------------------------------------------------------------------
## mm.BxI | lmerModLmerTest | 0.510 | 0.424 | 0.149 | 0.665 | 0.699 | 1.00 | 1.00 | 1.00 | 99.35%
## mm.I | lmerModLmerTest | 0.352 | 0.235 | 0.152 | 0.771 | 0.811 | 1.35e-102 | 1.37e-102 | 2.90e-100 | 21.06%
## mm.B | lmerModLmerTest | 0.302 | 0.221 | 0.104 | 0.800 | 0.832 | 9.71e-108 | 9.85e-108 | 2.09e-105 | 0.00%anova(mm.BxI, mm.B, mm.I)## refitting model(s) with ML (instead of REML)## Data: df
## Models:
## mm.B: TRUST_Z ~ BEAUTY_Z + (1 | PID)
## mm.I: TRUST_Z ~ INTENT_Z + (1 | PID)
## mm.BxI: TRUST_Z ~ INTENT_Z * BEAUTY_Z + (1 | PID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mm.B 4 4077.7 4099.2 -2034.8 4069.7
## mm.I 4 4054.0 4075.5 -2023.0 4046.0 23.682 0
## mm.BxI 6 3584.9 3617.1 -1786.4 3572.9 473.128 2 < 0.00000000000000022 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1# anova(mm.BxM, mm.BM)
print ("ADDING interaction BEAUTY * INTENT IMPROVES MODEL FIT ")## [1] "ADDING interaction BEAUTY * INTENT IMPROVES MODEL FIT "car::Anova(mm.BxI, type=3)## Analysis of Deviance Table (Type III Wald chisquare tests)
##
## Response: TRUST_Z
## Chisq Df Pr(>Chisq)
## (Intercept) 0.3097 1 0.5779
## INTENT_Z 486.8683 1 < 0.00000000000000022 ***
## BEAUTY_Z 488.4251 1 < 0.00000000000000022 ***
## INTENT_Z:BEAUTY_Z 49.3029 1 0.000000000002193 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(mm.BxI)## Linear mixed model fit by maximum likelihood . t-tests use Satterthwaite's
## method [lmerModLmerTest]
## Formula: TRUST_Z ~ INTENT_Z * BEAUTY_Z + (1 | PID)
## Data: df
##
## AIC BIC logLik deviance df.resid
## 3584.9 3617.1 -1786.4 3572.9 1584
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.4817 -0.5732 0.0277 0.5959 3.5702
##
## Random effects:
## Groups Name Variance Std.Dev.
## PID (Intercept) 0.0858 0.2929
## Residual 0.4883 0.6988
## Number of obs: 1590, groups: PID, 318
##
## Fixed effects:
## Estimate Std. Error df t value Pr(>|t|)
## (Intercept) 0.01341 0.02409 319.01936 0.557 0.578
## INTENT_Z -0.42141 0.01910 1585.84397 -22.065 < 0.0000000000000002
## BEAUTY_Z 0.41053 0.01858 1530.26022 22.100 < 0.0000000000000002
## INTENT_Z:BEAUTY_Z 0.12061 0.01718 1562.94682 7.022 0.00000000000326
##
## (Intercept)
## INTENT_Z ***
## BEAUTY_Z ***
## INTENT_Z:BEAUTY_Z ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) INTENT_Z BEAUTY
## INTENT_Z 0.011
## BEAUTY_Z -0.003 0.109
## INTENT_Z:BE 0.079 0.134 -0.040## REPORT
# report(mm.BxI)
## PLOT
## IN THE PAPER
plot_model(mm.BxI, type = "int", terms = c("BEAUTY_Z", "INTENT_Z"), mdrt.values = "all") +
labs(subtitle = f.BxI) + theme_minimal()
plot_model(mm.BxI, type = "pred", terms = c("BEAUTY_Z", "INTENT_Z")) +
labs(subtitle = f.BxI) + theme_minimal()
# means <- estimate_means(mm.BxI, at=c("BEAUTY_Z", "INTENT_Z"))
# contrasts <- estimate_contrasts(mm.BxI, c( "INTENT_Z", "BEAUTY_Z"), method="pairwise")
# plot(means, contrasts) #+ facet_wrap(~intent_Z) + labs(subtitle = f.BxI) + theme_minimal()
### IN THE PAPER
tab_model(mm.BxI)| TRUST Z | |||
|---|---|---|---|
| Predictors | Estimates | CI | p |
| (Intercept) | 0.01 | -0.03 – 0.06 | 0.578 |
| INTENT Z | -0.42 | -0.46 – -0.38 | <0.001 |
| BEAUTY Z | 0.41 | 0.37 – 0.45 | <0.001 |
| INTENT Z × BEAUTY Z | 0.12 | 0.09 – 0.15 | <0.001 |
| Random Effects | |||
| σ2 | 0.49 | ||
| τ00 PID | 0.09 | ||
| ICC | 0.15 | ||
| N PID | 318 | ||
| Observations | 1590 | ||
| Marginal R2 / Conditional R2 | 0.424 / 0.510 | ||
m <- mm.BxI4.1.0.2.7 BEST TRUST ~ BEAUTY X INTENT + DATA *** BEST MODEL ***
################## TRUST ~ BEAUTY X INTENT #################
f.BxID <- "TRUST ~ BEAUTY X INTENT+DATA + (1|PID)"
print("TRUST ~ BEAUTY X INTENT + DATA + (1|PID)")## [1] "TRUST ~ BEAUTY X INTENT + DATA + (1|PID)"mm.BxID <- lmer(TRUST_Z ~ INTENT_Z * BEAUTY_Z + DATA_Z + (1|PID), data = df, REML=FALSE)
compare_performance(mm.BxI, mm.BxID, rank = TRUE)## # Comparison of Model Performance Indices
##
## Name | Model | R2 (cond.) | R2 (marg.) | ICC | RMSE | Sigma | AIC weights | AICc weights | BIC weights | Performance-Score
## ------------------------------------------------------------------------------------------------------------------------------------------
## mm.BxID | lmerModLmerTest | 0.538 | 0.454 | 0.154 | 0.645 | 0.678 | 1.00 | 1.00 | 1.00 | 100.00%
## mm.BxI | lmerModLmerTest | 0.510 | 0.424 | 0.149 | 0.665 | 0.699 | 1.24e-19 | 1.26e-19 | 1.82e-18 | 0.00%anova(mm.BxI, mm.BxID)## Data: df
## Models:
## mm.BxI: TRUST_Z ~ INTENT_Z * BEAUTY_Z + (1 | PID)
## mm.BxID: TRUST_Z ~ INTENT_Z * BEAUTY_Z + DATA_Z + (1 | PID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mm.BxI 6 3584.9 3617.1 -1786.4 3572.9
## mm.BxID 7 3497.8 3535.4 -1741.9 3483.8 89.062 1 < 0.00000000000000022 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1# anova(mm.BxM, mm.BM)
car::Anova(mm.BxID, type=3)## Analysis of Deviance Table (Type III Wald chisquare tests)
##
## Response: TRUST_Z
## Chisq Df Pr(>Chisq)
## (Intercept) 0.2739 1 0.6007
## INTENT_Z 355.0287 1 < 0.00000000000000022 ***
## BEAUTY_Z 430.6410 1 < 0.00000000000000022 ***
## DATA_Z 91.6474 1 < 0.00000000000000022 ***
## INTENT_Z:BEAUTY_Z 44.1233 1 0.00000000003083 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1summary(mm.BxID)## Linear mixed model fit by maximum likelihood . t-tests use Satterthwaite's
## method [lmerModLmerTest]
## Formula: TRUST_Z ~ INTENT_Z * BEAUTY_Z + DATA_Z + (1 | PID)
## Data: df
##
## AIC BIC logLik deviance df.resid
## 3497.8 3535.4 -1741.9 3483.8 1583
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.6792 -0.5233 0.0358 0.5885 3.4931
##
## Random effects:
## Groups Name Variance Std.Dev.
## PID (Intercept) 0.08401 0.2898
## Residual 0.45998 0.6782
## Number of obs: 1590, groups: PID, 318
##
## Fixed effects:
## Estimate Std. Error df t value Pr(>|t|)
## (Intercept) 0.01235 0.02360 319.36146 0.523 0.601
## INTENT_Z -0.36636 0.01944 1585.81862 -18.842 < 0.0000000000000002
## BEAUTY_Z 0.38018 0.01832 1524.80667 20.752 < 0.0000000000000002
## DATA_Z -0.18660 0.01949 1569.46577 -9.573 < 0.0000000000000002
## INTENT_Z:BEAUTY_Z 0.11109 0.01672 1561.00264 6.643 0.0000000000425
##
## (Intercept)
## INTENT_Z ***
## BEAUTY_Z ***
## DATA_Z ***
## INTENT_Z:BEAUTY_Z ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) INTENT_Z BEAUTY DATA_Z
## INTENT_Z 0.009
## BEAUTY_Z -0.002 0.052
## DATA_Z 0.005 -0.297 0.171
## INTENT_Z:BE 0.079 0.111 -0.029 0.060## REPORT
# report(mm.BxI)
## PLOT
## IN THE PAPER
plot_model(mm.BxID, type = "int", terms = c("BEAUTY_Z", "INTENT_Z", "DATA_Z"), mdrt.values = "all") +
labs(subtitle = f.BxID) + theme_minimal()
plot_model(mm.BxID, type = "pred", terms = c("INTENT_Z", "BEAUTY_Z", "DATA_Z")) +
labs(subtitle = f.BxID) + theme_minimal()
## IN THE PAPER
tab_model(mm.BxID)| TRUST Z | |||
|---|---|---|---|
| Predictors | Estimates | CI | p |
| (Intercept) | 0.01 | -0.03 – 0.06 | 0.601 |
| INTENT Z | -0.37 | -0.40 – -0.33 | <0.001 |
| BEAUTY Z | 0.38 | 0.34 – 0.42 | <0.001 |
| DATA Z | -0.19 | -0.22 – -0.15 | <0.001 |
| INTENT Z × BEAUTY Z | 0.11 | 0.08 – 0.14 | <0.001 |
| Random Effects | |||
| σ2 | 0.46 | ||
| τ00 PID | 0.08 | ||
| ICC | 0.15 | ||
| N PID | 318 | ||
| Observations | 1590 | ||
| Marginal R2 / Conditional R2 | 0.454 / 0.538 | ||
# means <- estimate_means(mm.BxI, at=c("BEAUTY_Z", "INTENT_Z"))
# contrasts <- estimate_contrasts(mm.BxI, c( "INTENT_Z", "BEAUTY_Z"), method="pairwise")
# plot(means, contrasts) #+ facet_wrap(~intent_Z) + labs(subtitle = f.BxI) + theme_minimal()
tab_model(mm.BxID)| TRUST Z | |||
|---|---|---|---|
| Predictors | Estimates | CI | p |
| (Intercept) | 0.01 | -0.03 – 0.06 | 0.601 |
| INTENT Z | -0.37 | -0.40 – -0.33 | <0.001 |
| BEAUTY Z | 0.38 | 0.34 – 0.42 | <0.001 |
| DATA Z | -0.19 | -0.22 – -0.15 | <0.001 |
| INTENT Z × BEAUTY Z | 0.11 | 0.08 – 0.14 | <0.001 |
| Random Effects | |||
| σ2 | 0.46 | ||
| τ00 PID | 0.08 | ||
| ICC | 0.15 | ||
| N PID | 318 | ||
| Observations | 1590 | ||
| Marginal R2 / Conditional R2 | 0.454 / 0.538 | ||
anova(mm.B, mm.I, mm.D, mm.BxID)## refitting model(s) with ML (instead of REML)## Data: df
## Models:
## mm.B: TRUST_Z ~ BEAUTY_Z + (1 | PID)
## mm.I: TRUST_Z ~ INTENT_Z + (1 | PID)
## mm.D: TRUST_Z ~ DATA_Z + (1 | PID)
## mm.BxID: TRUST_Z ~ INTENT_Z * BEAUTY_Z + DATA_Z + (1 | PID)
## npar AIC BIC logLik deviance Chisq Df Pr(>Chisq)
## mm.B 4 4077.7 4099.2 -2034.8 4069.7
## mm.I 4 4054.0 4075.5 -2023.0 4046.0 23.682 0
## mm.D 4 4215.8 4237.3 -2103.9 4207.8 0.000 0
## mm.BxID 7 3497.8 3535.4 -1741.9 3483.8 723.966 3 < 0.00000000000000022
##
## mm.B
## mm.I
## mm.D
## mm.BxID ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1p <- plot_model(mm.BxID, type = "pred", terms = c("INTENT_Z", "BEAUTY_Z", "DATA_Z")) +
labs(subtitle = f.BxID) + theme_minimal()
ggsave(p, scale =1, filename = "figs/PAPER/mmBxID.svg", width = 14, height = 6, dpi = 320, limitsize = FALSE)
t <- tab_model(mm.BxID)
# ggsave(t, scale =1, filename = "figs/PAPER/mmBxID_table.png", width = 14, height = 6, dpi = 320, limitsize = FALSE)
# first save table to html file
tab_model(mm.BxID, file = "figs/PAPER/mmBxID_table.html")| TRUST Z | |||
|---|---|---|---|
| Predictors | Estimates | CI | p |
| (Intercept) | 0.01 | -0.03 – 0.06 | 0.601 |
| INTENT Z | -0.37 | -0.40 – -0.33 | <0.001 |
| BEAUTY Z | 0.38 | 0.34 – 0.42 | <0.001 |
| DATA Z | -0.19 | -0.22 – -0.15 | <0.001 |
| INTENT Z × BEAUTY Z | 0.11 | 0.08 – 0.14 | <0.001 |
| Random Effects | |||
| σ2 | 0.46 | ||
| τ00 PID | 0.08 | ||
| ICC | 0.15 | ||
| N PID | 318 | ||
| Observations | 1590 | ||
| Marginal R2 / Conditional R2 | 0.454 / 0.538 | ||
# then take this html file and make .png file
webshot("figs/PAPER/mmBxID_table.html", "figs/PAPER/mmBxID_table.png")
### not using
4.1.0.2.8 TRUST ~ BEAUTY X MAKER_ID
#
# ## ADD IXN EFFECT
# ################## TRUST ~ BEAUTY X MAKER_ID #################
# f.BxM <- "TRUST ~ BEAUTY X MAKER_ID + (1|PID)"
# print("TRUST ~ BEAUTY X MAKER_ID + (1|PID)")
# mm.BxM <- lmer(TRUST_Z ~ MAKER_ID * BEAUTY_Z + (1|PID), data = df)
# compare_performance(mm.BxM, mm.BM, rank = TRUE)
# test_lrt(mm.BxM, mm.BM)
# # anova(mm.BxM, mm.BM)
# print ("ADDING interaction MAKER ID IMPROVES MODEL FIT ")
# car::Anova(mm.BxM, type=3)
# summary(mm.BxM)
#
#
# ## REPORT
# report(mm.BxM)
#
# ## PLOT
# plot_model(mm.BxM, type = "int", terms = c("BEAUTY_Z", "MAKER_ID"), mdrt.values = "all") +
# labs(subtitle = f.BxM) + theme_minimal()
#
# plot_model(mm.BXM, type = "pred", terms = c("BEAUTY_Z", "MAKER_ID")) +
# labs(subtitle = f.BM) + theme_minimal()
#
# means <- estimate_means(mm.BM, at=c("BEAUTY_Z", "MAKER_ID"))
# contrasts <- estimate_contrasts(mm.BM, c( "MAKER_ID"),method="pairwise")
# plot(contrasts, means) + facet_wrap("MAKER_ID") + labs(subtitle = f.BxM) + theme_minimal()4.1.0.2.9 TRUST ~ BEAUTY X MAKER_ID
#
# ## ADD IXN EFFECT
# ################## TRUST ~ BEAUTY X MAKER_ID #################
# f.BxM <- "TRUST ~ BEAUTY X MAKER_ID + (1|PID)"
# print("TRUST ~ BEAUTY X MAKER_ID + (1|PID)")
# mm.BxM <- lmer(TRUST_Z ~ MAKER_ID * BEAUTY_Z + (1|PID), data = df)
# compare_performance(mm.BxM, mm.BM, rank = TRUE)
# test_lrt(mm.BxM, mm.BM)
# # anova(mm.BxM, mm.BM)
# print ("ADDING interaction MAKER ID IMPROVES MODEL FIT ")
# car::Anova(mm.BxM, type=3)
# summary(mm.BxM)
#
#
# ## REPORT
# report(mm.BxM)
#
# ## PLOT
# plot_model(mm.BxM, type = "int", terms = c("BEAUTY_Z", "MAKER_ID"), mdrt.values = "all") +
# labs(subtitle = f.BxM) + theme_minimal()
#
# plot_model(mm.BXM, type = "pred", terms = c("BEAUTY_Z", "MAKER_ID")) +
# labs(subtitle = f.BM) + theme_minimal()
#
# means <- estimate_means(mm.BM, at=c("BEAUTY_Z", "MAKER_ID"))
# contrasts <- estimate_contrasts(mm.BM, c( "MAKER_ID"),method="pairwise")
# plot(contrasts, means) + facet_wrap("MAKER_ID") + labs(subtitle = f.BxM) + theme_minimal()4.1.0.2.10 TRUST ~ BEAUTY X MAKER_ID X INTENT
# ## ADD IXN EFFECT
# ################## TRUST ~ BEAUTY X MAKER_ID #################
# f.BxMxI <- "TRUST ~ BEAUTY X MAKER_ID X INTENT+ (1|PID)"
# print("TRUST ~ BEAUTY X MAKER_ID X INTENT + (1|PID)")
# mm.BxMxI <- lmer(TRUST_Z ~ MAKER_ID * BEAUTY_Z* INTENT_Z + (1|PID), data = df)
# compare_performance(mm.BxMxI, mm.BxM, rank = TRUE)
# test_lrt(mm.BxMxI, mm.BxM)
# # anova(mm.BxM, mm.BM)
# car::Anova(mm.BxMxI, type=3)
# summary(mm.BxMxI)
#
#
# ## REPORT
# report(mm.BxMxI)
#
# ## PLOT
# plot_model(mm.BxMxI, type = "int", mdrt.values = "all")
#
# plot_model(mm.BxMxI, type = "pred", terms = c("BEAUTY_Z", "MAKER_ID", "INTENT_Z"))
#
# #
# # means <- estimate_means(mm.BM, at=c("BEAUTY_Z", "MAKER_ID"))
# # contrasts <- estimate_contrasts(mm.BM, c( "MAKER_ID"),method="pairwise")
# # plot(contrasts, means) + facet_wrap("MAKER_ID") + labs(subtitle = f.BxM) + theme_minimal()
#
# compare_performance(mm.BxI, mm.BxMxI, rank = TRUE)
# anova(mm.BxI, mm.BxMxI)
#
#
#
#
# # ## INTENT MAIN EFFECT
# # SUBJECT INTERCEPT | FIXED BEAUTY
# print("TRUSTS ~ INTENT + (1|PID)")
# mm.IrP <- lmer(CHART_TRUST ~ CHART_INTENT + (1|PID), data = df)
# # :: TEST fixed factor
# compare_performance(mm.rP, mm.BrP, mm.IrP, rank = TRUE)
# paste("AIC with INTENT is lower than BEAUTY model?", AIC(logLik(mm.BrP)) > AIC(logLik(mm.IrP)) )
# anova(mm.BrP, mm.IrP, test = "Chi") #same as anova(m0, m1, test = "Chi")
# print("A model with INTENT IS a better fit than model with BEAUTY")
# car::Anova(mm.IrP, type=2)
# print("BEAUTY IS a significant predictor in the model")
# summary(mm.IrP)
#
#
# ## BEAUTY AND INTENT MAIN EFFECTS
# # SUBJECT INTERCEPT | BEAUTY + INTENT
# print("TRUST ~ INTENT + BEAUTY + (1|PID)")
# mm.IBrP <- lmer(CHART_TRUST ~ CHART_INTENT + CHART_BEAUTY + (1|PID), data = df)
# # :: TEST fixed factor
# compare_performance(mm.rP, mm.BrP, mm.IrP, mm.IBrP, rank = TRUE)
# ##anova instead of LRT b/c models are not nested
# anova(mm.IrP,mm.IBrP, mm.BrP) #same as anova(m0, m1, test = "Chi")
# test_lrt(mm.IrP, mm.IBrP)
# test_lrt(mm.BrP, mm.IBrP)
# paste("A model with a linear combination of BEAUTY and INTENT predicting TRUST is a significantly better fit than either fixed effect alone.")
# car::Anova(mm.IBrP, type = 2)
# summary(mm.IBrP)
# print("CATEGORY is a significant predictor in this model, but BLOCK is not")
#
#
# ## BEAUTY INTENT INTERACTION
# # SUBJECT INTERCEPT | INTENT * BEAUTY
# print("TRUST ~ INTENT * BEAUTY + (1|PID)")
# mm.IBXrP <- lmer(CHART_TRUST ~ CHART_INTENT * CHART_BEAUTY + (1|PID),
# data = df)
# # control=glmerControl(optimizer="bobyqa", #would not converge under Nelder)Mead
# # optCtrl=list(maxfun=2e5)))
# # :: TEST fixed factor
# compare_performance(mm.IBXrP, mm.IBrP, mm.IrP, mm.BrP, rank = TRUE)
# ##anova instead of LRT b/c models are not nested
# anova(mm.IBXrP, mm.IBrP)
# test_lrt(mm.IBrP, mm.IBXrP, verbose = TRUE) #same as anova(m0, m1, test = "Chi")
# paste("A model with an interaction is significantly better fit")
# car::Anova(mm.IBXrP, type = 3)
# print("In this model, both the main effects and interaction are significant")
#
#
#
#
# #############VERSION WITH ZSCORED VARS
# ## BEAUTY INTENT INTERACTION
# # SUBJECT INTERCEPT | INTENT * BEAUTY
# print("TRUST ~ INTENT * BEAUTY + (1|PID)")
# mm.ZIBXrP <- lmer(TRUST_Z ~ INTENT_Z * BEAUTY_Z + (1|PID),
# data = df)
# # control=glmerControl(optimizer="bobyqa", #would not converge under Nelder)Mead
# # optCtrl=list(maxfun=2e5)))
# # :: TEST fixed factor
# compare_performance(mm.IBXrP, mm.ZIBXrP, rank = TRUE) ## should be the same
# ##anova instead of LRT b/c models are not nested
# car::Anova(mm.ZIBXrP, type = 3)
# summary(mm.ZIBXrP)
#
#
#
# ## SET BEST
# m_best <- mm.ZIBXrP
# f <- "(ZSCORED) TRUST ~ INTENT * BEAUTY"
#
#
# ############ PARTIAL CORRELATION SANITY CHECK
#
# # print("PARTIAL CORRELATION WITH PID AS RANDOM EFFECT")
# # #CALCULATE partial correlations with PID as random effect
# # ## (this isolates correlation pairwise factoring out other variables)
# # c <- df %>% correlation(partial=TRUE,multilevel = TRUE)
# # (s <- c %>% summary(redundant = FALSE ))
#
#
# # ###### VIS WITH CORRELATION PACKAGE
# # #SEE [correlation] PLOT
# # g <- plot(s, show_data = "point", show_text = "label",
# # stars=TRUE, show_legend=FALSE,
# # show_statistic = FALSE, show_ci = FALSE) +
# # theme_minimal()+
# # labs(title = "All Stimuli | Correlation Matrix — SD Questions",
# # subtitle="(partial correlation; pearson method; Holm p-value adjustment; participant as random effect)")
# # # text = list(fontface = "italic")
# # g
# # ggsave(g, scale =1, filename = "figs/level_aggregated/models/partial_correlation_mmIBXrP.png", width = 14, height = 6, dpi = 320, limitsize = FALSE)
#
# 4.1.0.3 model describe
# ############ DESCRIBE FINAL MODEL ###########
# summary(m_best)
# report(m_best)
#
#
# ######### PRINT COEFFICIENTS
# # print("COEFFICIENT ESTIMATES — LOG ODDS")
# # tidy(m_best)
# # print("COEFFICIENT ESTIMATES — ODDS RATIOS")
# # tidy(m_best, exponentiate=TRUE)4.1.0.4 check rescaling
#
# ## rescale all vars to be -1 to 0 to 1
# df <- df_graphs %>%
# ## FILTER OUT B0-0 COMMON STIMULUS (so cells can be balanced)
# # filter(STIMULUS != "B0-0") %>%
# select(PID, CHART_TRUST, CHART_BEAUTY, CHART_INTENT, MAKER_ID, STIMULUS_CATEGORY, MAKER_DATA) %>%
# mutate(
# TRUST_Z = datawizard::standardise(CHART_TRUST),
# BEAUTY_Z = datawizard::standardise(CHART_BEAUTY),
# INTENT_Z = datawizard::standardise(CHART_INTENT),
# r_MAKER_DATA = datawizard::reverse(MAKER_DATA), # reverse b/c 0 = professional, 100=layperson
# r_DATA_Z = datawizard::standardise(r_MAKER_DATA),
#
# TRUST_S = datawizard::rescale(CHART_TRUST, to=c(-1,1)),
# BEAUTY_S = datawizard::rescale(CHART_BEAUTY, to=c(-1,1)),
# INTENT_S = datawizard::rescale(CHART_INTENT, to=c(-1,1)),
# DATA_S = datawizard::rescale(MAKER_DATA, to=c(-1,1)),
# r_DATA_S = datawizard::reverse(DATA_S), # reverse b/c 0 = professional, 100=layperson
#
# TRUST_SZ = datawizard::standardise(TRUST_S, to=c(-1,1))
#
# ) %>%
# droplevels()
#
#
#
# gf_histogram(df, ~CHART_TRUST)
# gf_histogram(df, ~TRUST_S)
# gf_histogram(df, ~TRUST_Z)
# gf_histogram(df, ~TRUST_SZ)
# 4.1.0.5 model vis
#
# ############ VISUALIZE MODEL COEFFICIENTS
# #SJPLOT | MODEL | ODDS RATIO
# #library(sjPlot)
# plot_model(mm.ZIBXrP, type = "est",
# vline.color = "red",
# show.intercept = TRUE,
# show.values = TRUE) + theme_minimal() +
# labs(title = "Model Coefficients",
# subtitle = "")
#
#
#
# ############ VISUALIZE MODEL PREDICTIONS
# #SJPLOT | MODEL | PROBABILITIES
# plot_model(m_best, type = "int", mdrt.values = "meansd") + theme_minimal()
#
#
# plot_model(m_best, type="emm",
# terms = c("BEAUTY_Z"), ci.lvl = 0.95) + theme_minimal() +
# labs(title = "Estimated Marginal Means for BEAUTY")
#
# plot_model(m_best, type="emm",
# terms = c("INTENT_Z"), ci.lvl = 0.95) + theme_minimal() +
# labs(title = "Estimated Marginal Means for INTENT")
#
# plot_model(m_best, type="emm",
# terms = c("BEAUTY_Z","INTENT_Z"), ci.lvl = 0.95) + theme_minimal() +
# labs(title = "Estimated Marginal Means for INTERACTION")
#
# plot_model(m_best, type="emm",
# terms = c("INTENT_Z", "BEAUTY_Z"), ci.lvl = 0.95) + theme_minimal() +
# labs(title = "Estimated Marginal Means for INTERACTION")
#
#
#
# ## CONTINUOUS INTERACTIONS
# result <- estimate_expectation(m_best, data = "grid")
# plot(result) + theme_minimal()
#
# result <- estimate_expectation(m_alt, data = "grid")
# plot(result) + theme_minimal()
#
#
# result <- estimate_prediction(m_best, data = "grid")
# plot(result) + theme_minimal()
#
#
#
#
#
# ##EXAMPLES NOT WORKING EITHER
# # slopes <- estimate_slopes(m_best, trend = "INTENT_Z", by = "BEAUTY_Z")
# # plot(slopes)
#
#
# # model <- lm(mpg ~ hp * wt, data = mtcars)
# # slopes <- estimate_slopes(model, trend = "hp", by = "wt")
# # plot(slopes)
#
#
#
#
# ## TRY ADDING MAKER ID
#
# mm.beauty <- lmer(TRUST_Z ~ BEAUTY_Z + (1|PID), data = df)
# mm.intent <- lmer(TRUST_Z ~ INTENT_Z + (1|PID), data = df)
# mm.makerbeauty <- lmer(TRUST_Z ~ BEAUTY_Z*MAKER_ID + (1|PID), data = df)
#
#
#
# plot_model(mm.beauty, type = "eff", terms = "BEAUTY_Z")
# plot_model(mm.intent, type = "eff", terms = "INTENT_Z")
#
# plot_model(mm.makerbeauty, type = "int")
#
#
#
# plot_model(m_best, type = "int")
#
#
# plot_model(m_best, type = "int", mdrt.values = "all")
#
#
# mm.icat = update(m_best, .~. *MAKER_ID)
# compare_performance(m_best, mm.icat, mm.idata, rank = TRUE)
# car::Anova(mm.icat, type=3)
# plot_model(mm.icat, type = "int", mdrt.values = "meansd")
#
# mm.idata = update(m_best, .~. *r_DATA_Z)
# compare_performance(m_best, mm.icat, mm.idata, rank = TRUE)
# car::Anova(mm.idata, type=3)
# plot_model(mm.idata, type = "int", mdrt.values = "meansd")
#
#
#
# # plot_model(mm.ZIBXrP, type = "est",vline.color = "red", show.intercept = TRUE, show.values = TRUE) + theme_minimal() +
# # labs(title = "Model Coefficients", subtitle = "")
# # plot_model(mm.cat, type = "est",vline.color = "red", show.intercept = TRUE, show.values = TRUE) + theme_minimal() +
# # labs(title = "Model Coefficients", subtitle = "")
# # plot_model(mm.cat, type = "emm", terms=c("MAKER_ID" , "INTENT_Z","BEAUTY_Z"))
#
#
#
# 5 EXPLORATORY QUESTIONS
- When participants identify the maker as an INDIVIDUAL, the following variables show a different pattern than the other identifications: MAKER_DESIGN, MAKER_DATA, CHART INTENT
- interesting bimodal distribution on CHART INTENT for most identifications, except individuals and organizations
5.0.1 TOOL ID & DATA COMPETENCY
df <- df_tools
## Does DATA COMPETENCY depend on TOOL ID?
##RIDGEPLOT w/ MEAN
answers <- levels(df$TOOL_ID)
left <- rep(ref_labels['MAKER_DATA','left'], length(levels(df$MAKER_ID)))
right <- rep(ref_labels['MAKER_DATA','right'], length(levels(df$MAKER_ID)))
df %>%
group_by(TOOL_ID) %>%
mutate(
md=median(MAKER_DATA),
m=mean(MAKER_DATA),
count = n()
) %>% droplevels() %>%
ggplot(aes(y = TOOL_ID, x= MAKER_DATA, fill = TOOL_ID)) +
# scale_x_continuous(limits = c(0,100))+
# geom_density_ridges(scale = 0.55,quantile_lines = TRUE, alpha = 0.75) +
stat_halfeye(scale=0.8, density="bounded", point_interval = "median_qi", normalize="groups") +
stat_pointinterval(side = "bottom", scale = 0.7, slab_linewidth = NA, point_interval = "median_qi") +
##MEDIAN
stat_summary(fun=median, geom="text", colour="red", fontface = "bold", size = 2.5,
vjust=+2, hjust = 0, aes( label=round(md, digits=0)))+
stat_summary(fun=median, geom="point", shape=20, size=3, color="red", fill="red") +
## MEAN
stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold", size = 2.5,
vjust=+2, hjust = 0, aes( label=round(m, digits=0)))+
stat_summary(fun="mean", geom="point", shape=20, size=3, color="blue", fill="blue") +
scale_fill_manual(values = my_palettes(name="tools", direction = "-1"), name = "", guide = guide_legend(reverse = TRUE)) +
guides(
y = guide_axis_manual(labels = left, title = ""),
y.sec = guide_axis_manual(labels = right)
) +
geom_text(aes(label= paste0("n=",count) , y = TOOL_ID, x = 5), color = "black",size = 3, nudge_y = 0.3) +
cowplot::draw_text(text = toupper(answers), x = 80, y= answers, size = 10, vjust=-2, hjust=0) +
labs (title = "DATA COMPETENCY by TOOL ID", y = "", x = "MAKER DATA COMPETENCY", caption="(mean in blue) (median in red)") +
theme_minimal() + easy_remove_legend()
5.0.1.1 TODO PICKUP HERE model
#
# df <- df_tools %>%
# mutate(
# ## reverse order of MAKER_DATA, because scale ranged from 0=expert to 100=layperson
# ## we want the reverse
# ## chose NOT to z-score data, bc we want the data in terms of the original scale
# r_MAKER_DATA = reverse_scale(MAKER_DATA),
# STIMULUS_CATEGORY = fct_rev(STIMULUS_CATEGORY)
# ) %>% filter(STIMULUS!="B0-0")
#
# ## SET CONTRASTS
# # contrasts(df$MAKER_ID) <-car::contr.Treatment(levels(df$MAKER_ID)) # intercept first group mean; coeff dif from first
#
# ## DEFINE MODEL
# lm5 <-lmer(r_MAKER_DATA ~ TOOL_ID + STIMULUS_CATEGORY*BLOCK + (1|PID) , data=df)
#
# # ## PRINT MODEL
# # (m_eq <- extract_eq(m1, use_coef = TRUE, ital_vars = TRUE, coef_digits = 1, wrap = TRUE, intercept = "beta"))
#
# ## DESCRIBE MODEL
# summary(lm5)
# anova(lm5)
# performance(m1)
# report(m1)
#
# ## PLOT MODEL COEFFICIENTS
# coefs <- model_parameters(m1)
# plot_model(m1, type = "est",
# # show.intercept = TRUE,
# show.values = TRUE,
# value.offset = .25,
# show.p = TRUE
# ) + theme_minimal() + labs(caption=f)
#
#
# ## PLOT MODEL PREDICTIONS
# means <- estimate_means(m1, at = c("TOOL_ID"))
#
# # sjPlot::plot_model(m1, type = "pred", terms = c("MAKER_ID")) +
# # theme_minimal() + labs(caption=f)
#
# # plot(means) + theme_minimal() + labs(caption=f) +
# # geom_text(aes(x=means$MAKER_ID, y=means$Mean, label=round(means$Mean,1)),
# # color="blue", position = position_nudge(x=0.25))
#
#
# ## PLOT MODEL PREDICTIONS with CONTRASTS
#
# ## contrasts
# # black = estimated means and CI range; grey = CI range of the difference (as compared to the point estimate).
# (contrasts <- estimate_contrasts(m1, contrast="TOOL_ID", method="pairwise"))
# plot(contrasts, means) +
# geom_text(aes(x=means$TOOL_ID, y=means$Mean, label=round(means$Mean,2)), color="blue", position = position_nudge(x=0.25)) +
# theme_minimal() + labs(caption =f, y="predicted MAKER DATA COMPETENCY \n (0=layperson, 100=expert)")
#
# ##prediced data
# plot_model(m1, type = "eff", terms = "TOOL_ID", show.p = TRUE,
# show.values = TRUE, auto.label = TRUE)# <!-- ### JK DO QUANTILE REGRESSION AT THE MEDIAN -->
# <!-- library(qrLMM) -->
#
#
#
# <!-- ## tau is the quantile on which to run the model -->
# <!-- m2 <-df %>% QRLMM( -->
# <!-- y = r_MAKER_DATA, -->
# <!-- r_MAKER_DATA ~ TOOL_ID, -->
# <!-- random = ~ 1, -->
# <!-- group = PID, -->
# <!-- data=df, tau = 0.5) -->
#
#
#
# <!-- summary(m2) -->
# <!-- plot_model(m1) -->5.0.2 MAKER ID & Maker DATA COMPETENCY
df <- df_graphs
## Does MAKER_DATA depend on MAKER ID?
##RIDGEPLOT w/ MEAN
answers <- levels(df$MAKER_ID)
left <- rep(ref_labels['MAKER_DATA','left'], length(levels(df$MAKER_ID)))
right <- rep(ref_labels['MAKER_DATA','right'], length(levels(df$MAKER_ID)))
df %>%
group_by(MAKER_ID) %>%
mutate(
md=median(MAKER_DATA),
m=mean(MAKER_DATA),
count = n()
) %>%
ggplot(aes(y = fct_rev(MAKER_ID), x= MAKER_DATA, fill = fct_rev(MAKER_ID))) +
scale_x_continuous(limits = c(0,100))+
geom_density_ridges(scale = 0.55,quantile_lines = TRUE, alpha = 0.75) +
stat_pointinterval(side = "bottom", scale = 0.7, slab_linewidth = NA, point_interval = "mean_qi") +
##MEDIAN
stat_summary(fun=median, geom="text", colour="red", fontface = "bold", size = 2.5,
vjust=+2, hjust = 0, aes( label=round(md, digits=0)))+
stat_summary(fun=median, geom="point", shape=20, size=3, color="red", fill="red") +
## MEAN
stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold", size = 2.5,
vjust=+2, hjust = 0, aes( label=round(m, digits=0)))+
stat_summary(fun="mean", geom="point", shape=20, size=3, color="blue", fill="blue") +
scale_fill_manual(values = my_palettes(name="reds", direction = "-1"), name = "", guide = guide_legend(reverse = TRUE)) +
guides(
y = guide_axis_manual(labels = left, title = ""),
y.sec = guide_axis_manual(labels = right)
) +
geom_text(aes(label= paste0("n=",count) , y = MAKER_ID, x = 100), color = "black",size = 3, nudge_y = 0.25) +
cowplot::draw_text(text = toupper(answers), x = 0, y= answers, size = 10, vjust=-2, hjust=0) +
labs (title = "DATA COMPETENCY by MAKER ID", y = "", x = "MAKER DATA COMPETENCY", caption="(mean in blue) (median in red)") +
theme_minimal() + easy_remove_legend()## Picking joint bandwidth of 7.9
5.0.2.1 (YES) model
### LINEAR MIXED EFFECTS MODEL ##################
df <- df_graphs
## SET CONTRASTS
contrasts(df$MAKER_ID) <-car::contr.Treatment(levels(df$MAKER_ID)) # intercept first group mean; coeff dif from first
## DEFINE MODEL
f <- "MAKER_DATA ~ MAKER_ID + (1|PID) + (1|STIMULUS)"
m1 <-lmer(MAKER_DATA ~ MAKER_ID + (1|PID) + (1|STIMULUS), data=df)
## PRINT MODEL
(m_eq <- extract_eq(m1, use_coef = TRUE, ital_vars = TRUE, coef_digits = 1, wrap = TRUE, intercept = "beta"))\[ \begin{aligned} \widehat{MAKER\_DATA}_{i} &\sim N \left(54.3_{\alpha_{j[i],k[i]}}, \sigma^2 \right) \\ \alpha_{j} &\sim N \left(-8_{\gamma_{1}^{\alpha}}(MAKER\_ID_{[T.organization]}) - 20.1_{\gamma_{2}^{\alpha}}(MAKER\_ID_{[T.education]}) - 13.5_{\gamma_{3}^{\alpha}}(MAKER\_ID_{[T.business]}) - 13.7_{\gamma_{4}^{\alpha}}(MAKER\_ID_{[T.news]}) - 16.4_{\gamma_{5}^{\alpha}}(MAKER\_ID_{[T.political]}), 9 \right) \text{, for PID j = 1,} \dots \text{,J} \\ \alpha_{k} &\sim N \left(0, 11.5 \right) \text{, for STIMULUS k = 1,} \dots \text{,K} \end{aligned} \]
## DESCRIBE MODEL
summary(m1)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: MAKER_DATA ~ MAKER_ID + (1 | PID) + (1 | STIMULUS)
## Data: df
##
## REML criterion at convergence: 14572.2
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -2.7463 -0.6693 -0.0982 0.6322 3.2701
##
## Random effects:
## Groups Name Variance Std.Dev.
## PID (Intercept) 80.33 8.963
## STIMULUS (Intercept) 131.58 11.471
## Residual 482.62 21.969
## Number of obs: 1590, groups: PID, 318; STIMULUS, 25
##
## Fixed effects:
## Estimate Std. Error df t value
## (Intercept) 54.340 3.023 60.428 17.976
## MAKER_ID[T.organization] -7.970 2.878 1523.019 -2.770
## MAKER_ID[T.education] -20.131 2.180 1504.192 -9.236
## MAKER_ID[T.business] -13.458 2.294 1538.056 -5.866
## MAKER_ID[T.news] -13.679 2.370 1527.078 -5.771
## MAKER_ID[T.political] -16.415 2.484 1546.715 -6.607
## Pr(>|t|)
## (Intercept) < 0.0000000000000002 ***
## MAKER_ID[T.organization] 0.00567 **
## MAKER_ID[T.education] < 0.0000000000000002 ***
## MAKER_ID[T.business] 0.0000000054420 ***
## MAKER_ID[T.news] 0.0000000095283 ***
## MAKER_ID[T.political] 0.0000000000537 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) MAKER_ID[T.r] MAKER_ID[T.d] MAKER_ID[T.b] MAKER_ID[T.n]
## MAKER_ID[T.r] -0.381
## MAKER_ID[T.d] -0.527 0.509
## MAKER_ID[T.b] -0.513 0.491 0.697
## MAKER_ID[T.n] -0.518 0.500 0.678 0.658
## MAKER_ID[T.p] -0.498 0.478 0.639 0.619 0.652anova(m1)## Type III Analysis of Variance Table with Satterthwaite's method
## Sum Sq Mean Sq NumDF DenDF F value Pr(>F)
## MAKER_ID 45061 9012.2 5 1493.3 18.673 < 0.00000000000000022 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1performance(m1)## # Indices of model performance
##
## AIC | AICc | BIC | R2 (cond.) | R2 (marg.) | ICC | RMSE | Sigma
## -------------------------------------------------------------------------------------
## 14590.159 | 14590.273 | 14638.503 | 0.340 | 0.051 | 0.305 | 20.756 | 21.969report(m1)## We fitted a linear mixed model (estimated using REML and nloptwrap optimizer)
## to predict MAKER_DATA with MAKER_ID (formula: MAKER_DATA ~ MAKER_ID). The model
## included PID as random effects (formula: list(~1 | PID, ~1 | STIMULUS)). The
## model's total explanatory power is substantial (conditional R2 = 0.34) and the
## part related to the fixed effects alone (marginal R2) is of 0.05. The model's
## intercept, corresponding to MAKER_ID = individual, is at 54.34 (95% CI [48.41,
## 60.27], t(1581) = 17.98, p < .001). Within this model:
##
## - The effect of MAKER ID[T.organization] is statistically significant and
## negative (beta = -7.97, 95% CI [-13.61, -2.33], t(1581) = -2.77, p = 0.006;
## Std. beta = -0.29, 95% CI [-0.49, -0.08])
## - The effect of MAKER ID[T.education] is statistically significant and negative
## (beta = -20.13, 95% CI [-24.41, -15.86], t(1581) = -9.24, p < .001; Std. beta =
## -0.73, 95% CI [-0.88, -0.57])
## - The effect of MAKER ID[T.business] is statistically significant and negative
## (beta = -13.46, 95% CI [-17.96, -8.96], t(1581) = -5.87, p < .001; Std. beta =
## -0.49, 95% CI [-0.65, -0.32])
## - The effect of MAKER ID[T.news] is statistically significant and negative
## (beta = -13.68, 95% CI [-18.33, -9.03], t(1581) = -5.77, p < .001; Std. beta =
## -0.49, 95% CI [-0.66, -0.33])
## - The effect of MAKER ID[T.political] is statistically significant and negative
## (beta = -16.41, 95% CI [-21.29, -11.54], t(1581) = -6.61, p < .001; Std. beta =
## -0.59, 95% CI [-0.77, -0.42])
##
## Standardized parameters were obtained by fitting the model on a standardized
## version of the dataset. 95% Confidence Intervals (CIs) and p-values were
## computed using a Wald t-distribution approximation.## PLOT MODEL COEFFICIENTS
coefs <- model_parameters(m1)
plot_model(m1, type = "est",
show.intercept = TRUE,
show.values = TRUE,
value.offset = .25,
show.p = TRUE
) + theme_minimal() + labs(caption=f)
## PLOT MODEL PREDICTIONS
means <- estimate_means(m1, at = c("MAKER_ID"))
# sjPlot::plot_model(m1, type = "pred", terms = c("MAKER_ID")) +
# theme_minimal() + labs(caption=f)
# plot(means) + theme_minimal() + labs(caption=f) +
# geom_text(aes(x=means$MAKER_ID, y=means$Mean, label=round(means$Mean,1)),
# color="blue", position = position_nudge(x=0.25))
## PLOT MODEL PREDICTIONS with CONTRASTS
## contrasts
# black = estimated means and CI range; grey = CI range of the difference (as compared to the point estimate).
(contrasts <- estimate_contrasts(m1, contrast="MAKER_ID", method="pairwise"))## Marginal Contrasts Analysis
##
## Level1 | Level2 | Difference | 95% CI | SE | df | t | p
## --------------------------------------------------------------------------------------------
## business | news | 0.22 | [ -5.47, 5.91] | 1.93 | 1477.69 | 0.11 | 0.909
## business | political | 2.96 | [ -3.21, 9.12] | 2.10 | 1493.91 | 1.41 | 0.476
## education | business | -6.67 | [-11.80, -1.54] | 1.75 | 1450.53 | -3.82 | 0.001
## education | news | -6.45 | [-11.85, -1.05] | 1.84 | 1457.70 | -3.51 | 0.004
## education | political | -3.72 | [ -9.61, 2.18] | 2.01 | 1503.73 | -1.85 | 0.256
## individual | business | 13.46 | [ 6.70, 20.22] | 2.30 | 1538.67 | 5.85 | < .001
## individual | education | 20.13 | [ 13.71, 26.55] | 2.18 | 1505.25 | 9.22 | < .001
## individual | news | 13.68 | [ 6.70, 20.66] | 2.38 | 1527.70 | 5.76 | < .001
## individual | organization | 7.97 | [ -0.50, 16.44] | 2.88 | 1524.06 | 2.77 | 0.040
## individual | political | 16.41 | [ 9.09, 23.73] | 2.49 | 1547.12 | 6.59 | < .001
## news | political | 2.74 | [ -3.23, 8.71] | 2.03 | 1487.65 | 1.35 | 0.476
## organization | business | 5.49 | [ -2.34, 13.31] | 2.66 | 1508.62 | 2.06 | 0.197
## organization | education | 12.16 | [ 4.57, 19.75] | 2.58 | 1508.15 | 4.71 | < .001
## organization | news | 5.71 | [ -2.12, 13.54] | 2.66 | 1499.60 | 2.14 | 0.193
## organization | political | 8.44 | [ 0.32, 16.57] | 2.76 | 1520.19 | 3.05 | 0.018
##
## Marginal contrasts estimated at MAKER_ID
## p-value adjustment method: Holm (1979)plot(contrasts, means) +
geom_text(aes(x=means$MAKER_ID, y=means$Mean, label=round(means$Mean,1)), color="blue", position = position_nudge(x=0.25)) +
theme_minimal() + labs(caption = f)
5.0.3 Maker ID & Maker DESIGN COMPETENCY
df <- df_graphs
## Does MAKER_DESIGN depend on MAKER ID?
##RIDGEPLOT w/ MEAN
answers <- levels(df$MAKER_ID)
left <- rep(ref_labels['MAKER_DESIGN','left'], length(levels(df$MAKER_ID)))
right <- rep(ref_labels['MAKER_DESIGN','right'], length(levels(df$MAKER_ID)))
df %>%
group_by(MAKER_ID) %>%
mutate(
count = n(),
m = mean(MAKER_DESIGN),
md = median(MAKER_DESIGN)
) %>%
ggplot(aes(y = fct_rev(MAKER_ID), x= MAKER_DESIGN, fill = fct_rev(MAKER_ID))) +
scale_x_continuous(limits = c(0,100))+
geom_density_ridges(scale = 0.55,quantile_lines = TRUE, alpha = 0.75) +
stat_pointinterval(side = "bottom", scale = 0.7, slab_linewidth = NA, point_interval = "mean_qi") +
##MEDIAN
stat_summary(fun=median, geom="text", colour="red", fontface = "bold", size = 2.5,
vjust=+2, hjust = 0, aes( label=round(md, digits=0)))+
stat_summary(fun=median, geom="point", shape=20, size=3, color="red", fill="red") +
##MEAN
stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold", size = 2.5,
vjust=+2, hjust = 0, aes( label=round(m, digits=0)))+
stat_summary(fun="mean", geom="point", shape=20, size=3, color="blue", fill="blue") +
scale_fill_manual(values = my_palettes(name="reds", direction = "-1"), name = "", guide = guide_legend(reverse = TRUE)) +
guides(
y = guide_axis_manual(labels = left, title = ""),
y.sec = guide_axis_manual(labels = right)
) +
geom_text(aes(label= paste0("n=",count) , y = MAKER_ID, x = 100), color = "black",size = 3, nudge_y = 0.25) +
cowplot::draw_text(text = toupper(answers), x = 0, y= answers, size = 10, vjust=-2, hjust=0) +
labs (title = "DESIGN COMPETENCY by MAKER ID", y = "", x = "MAKER DESIGN COMPETENCY", caption="(mean in blue) (median in red)") +
theme_minimal() + easy_remove_legend()## Picking joint bandwidth of 8.17
5.0.3.1 (YES) model
### LINEAR MIXED EFFECTS MODEL ##################
df <- df_graphs
## DEFINE MODEL
f <- "MAKER_DESIGN ~ MAKER_ID + (1|PID) + (1|STIMULUS)"
m1 <-lmer(MAKER_DESIGN ~ MAKER_ID + (1|PID) + (1|STIMULUS), data=df)
## PRINT MODEL
(m_eq <- extract_eq(m1, use_coef = TRUE, ital_vars = TRUE, coef_digits = 1, wrap = TRUE, intercept = "beta"))\[ \begin{aligned} \widehat{MAKER\_DESIGN}_{i} &\sim N \left(62.5_{\alpha_{j[i],k[i]}}, \sigma^2 \right) \\ \alpha_{j} &\sim N \left(-15.7_{\gamma_{1}^{\alpha}}(MAKER\_ID_{organization}) - 12.3_{\gamma_{2}^{\alpha}}(MAKER\_ID_{education}) - 15.7_{\gamma_{3}^{\alpha}}(MAKER\_ID_{business}) - 23.9_{\gamma_{4}^{\alpha}}(MAKER\_ID_{news}) - 20.2_{\gamma_{5}^{\alpha}}(MAKER\_ID_{political}), 8.3 \right) \text{, for PID j = 1,} \dots \text{,J} \\ \alpha_{k} &\sim N \left(0, 11.8 \right) \text{, for STIMULUS k = 1,} \dots \text{,K} \end{aligned} \]
## DESCRIBE MODEL
summary(m1)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: MAKER_DESIGN ~ MAKER_ID + (1 | PID) + (1 | STIMULUS)
## Data: df
##
## REML criterion at convergence: 14710.7
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.2704 -0.6818 -0.0276 0.6768 2.5092
##
## Random effects:
## Groups Name Variance Std.Dev.
## PID (Intercept) 68.24 8.261
## STIMULUS (Intercept) 139.11 11.794
## Residual 539.31 23.223
## Number of obs: 1590, groups: PID, 318; STIMULUS, 25
##
## Fixed effects:
## Estimate Std. Error df t value Pr(>|t|)
## (Intercept) 62.526 3.125 61.610 20.009 < 0.0000000000000002
## MAKER_IDorganization -15.661 3.018 1539.762 -5.189 0.0000002390642451
## MAKER_IDeducation -12.298 2.288 1522.194 -5.374 0.0000000888493856
## MAKER_IDbusiness -15.683 2.405 1554.156 -6.520 0.0000000000946328
## MAKER_IDnews -23.929 2.486 1543.471 -9.625 < 0.0000000000000002
## MAKER_IDpolitical -20.195 2.603 1561.314 -7.757 0.0000000000000156
##
## (Intercept) ***
## MAKER_IDorganization ***
## MAKER_IDeducation ***
## MAKER_IDbusiness ***
## MAKER_IDnews ***
## MAKER_IDpolitical ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) MAKER_IDr MAKER_IDd MAKER_IDb MAKER_IDn
## MAKER_IDrgn -0.386
## MAKER_IDdct -0.534 0.509
## MAKER_IDbsn -0.519 0.490 0.696
## MAKER_IDnws -0.524 0.500 0.676 0.656
## MAKER_IDplt -0.505 0.477 0.638 0.618 0.651anova(m1)## Type III Analysis of Variance Table with Satterthwaite's method
## Sum Sq Mean Sq NumDF DenDF F value Pr(>F)
## MAKER_ID 55394 11079 5 1510.8 20.542 < 0.00000000000000022 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1performance(m1)## # Indices of model performance
##
## AIC | AICc | BIC | R2 (cond.) | R2 (marg.) | ICC | RMSE | Sigma
## -------------------------------------------------------------------------------------
## 14728.725 | 14728.839 | 14777.069 | 0.323 | 0.063 | 0.278 | 22.104 | 23.223report(m1)## We fitted a linear mixed model (estimated using REML and nloptwrap optimizer)
## to predict MAKER_DESIGN with MAKER_ID (formula: MAKER_DESIGN ~ MAKER_ID). The
## model included PID as random effects (formula: list(~1 | PID, ~1 | STIMULUS)).
## The model's total explanatory power is substantial (conditional R2 = 0.32) and
## the part related to the fixed effects alone (marginal R2) is of 0.06. The
## model's intercept, corresponding to MAKER_ID = individual, is at 62.53 (95% CI
## [56.40, 68.65], t(1581) = 20.01, p < .001). Within this model:
##
## - The effect of MAKER ID [organization] is statistically significant and
## negative (beta = -15.66, 95% CI [-21.58, -9.74], t(1581) = -5.19, p < .001;
## Std. beta = -0.55, 95% CI [-0.76, -0.34])
## - The effect of MAKER ID [education] is statistically significant and negative
## (beta = -12.30, 95% CI [-16.79, -7.81], t(1581) = -5.37, p < .001; Std. beta =
## -0.43, 95% CI [-0.59, -0.28])
## - The effect of MAKER ID [business] is statistically significant and negative
## (beta = -15.68, 95% CI [-20.40, -10.96], t(1581) = -6.52, p < .001; Std. beta =
## -0.55, 95% CI [-0.72, -0.39])
## - The effect of MAKER ID [news] is statistically significant and negative (beta
## = -23.93, 95% CI [-28.81, -19.05], t(1581) = -9.62, p < .001; Std. beta =
## -0.84, 95% CI [-1.02, -0.67])
## - The effect of MAKER ID [political] is statistically significant and negative
## (beta = -20.19, 95% CI [-25.30, -15.09], t(1581) = -7.76, p < .001; Std. beta =
## -0.71, 95% CI [-0.89, -0.53])
##
## Standardized parameters were obtained by fitting the model on a standardized
## version of the dataset. 95% Confidence Intervals (CIs) and p-values were
## computed using a Wald t-distribution approximation.## PLOT MODEL COEFFICIENTS
coefs <- model_parameters(m1)
plot_model(m1, type = "est",
show.intercept = TRUE,
show.values = TRUE,
show.p = TRUE
) + theme_minimal() + labs(caption=f)
## PLOT MODEL PREDICTIONS
means <- estimate_means(m1, at = c("MAKER_ID"))
# sjPlot::plot_model(m1, type = "pred", terms = c("MAKER_ID")) +
# theme_minimal() + labs(caption=f)
# plot(means) + theme_minimal() + labs(caption=f) +
# geom_text(aes(x=means$MAKER_ID, y=means$Mean, label=round(means$Mean,1)),
# color="blue", position = position_nudge(x=0.25))
## PLOT MODEL PREDICTIONS with CONTRASTS
## contrasts
# black = estimated means and CI range; grey = CI range of the difference (as compared to the point estimate).
(contrasts <- estimate_contrasts(m1, contrast="MAKER_ID", method="pairwise"))## Marginal Contrasts Analysis
##
## Level1 | Level2 | Difference | 95% CI | SE | df | t | p
## -----------------------------------------------------------------------------------------------
## business | news | 8.25 | [ 2.27, 14.22] | 2.03 | 1496.07 | 4.06 | < .001
## business | political | 4.51 | [ -1.96, 10.99] | 2.20 | 1512.04 | 2.05 | 0.244
## education | business | 3.38 | [ -2.01, 8.78] | 1.84 | 1468.49 | 1.84 | 0.327
## education | news | 11.63 | [ 5.95, 17.31] | 1.93 | 1475.26 | 6.02 | < .001
## education | political | 7.90 | [ 1.71, 14.09] | 2.11 | 1521.55 | 3.75 | 0.001
## individual | business | 15.68 | [ 8.60, 22.77] | 2.41 | 1554.59 | 6.51 | < .001
## individual | education | 12.30 | [ 5.56, 19.04] | 2.29 | 1523.08 | 5.36 | < .001
## individual | news | 23.93 | [ 16.60, 31.26] | 2.49 | 1543.93 | 9.60 | < .001
## individual | organization | 15.66 | [ 6.78, 24.55] | 3.02 | 1540.54 | 5.18 | < .001
## individual | political | 20.19 | [ 12.52, 27.87] | 2.61 | 1561.56 | 7.74 | < .001
## news | political | -3.73 | [-10.01, 2.54] | 2.13 | 1506.23 | -1.75 | 0.327
## organization | business | 0.02 | [ -8.19, 8.23] | 2.79 | 1526.44 | 7.63e-03 | 0.994
## organization | education | -3.36 | [-11.32, 4.60] | 2.71 | 1525.72 | -1.24 | 0.429
## organization | news | 8.27 | [ 0.05, 16.48] | 2.79 | 1517.53 | 2.96 | 0.022
## organization | political | 4.53 | [ -3.99, 13.06] | 2.90 | 1537.12 | 1.56 | 0.355
##
## Marginal contrasts estimated at MAKER_ID
## p-value adjustment method: Holm (1979)plot(contrasts, means) +
geom_text(aes(x=means$MAKER_ID, y=means$Mean, label=round(means$Mean,1)), color="blue", position = position_nudge(x=0.25)) +
theme_minimal() + labs(caption = f)
maker_design, chart_like, chart_beauty for BOOMER vs. others
maker_data for gen Z vs others
maker-data for FEMALE
maker data for design-basic, interesting pattern
look closer at chart beauty
interesting pattern across values on chart intent
— no difference at ALL in maker data - interesting! - chart beauty very diff - chart intent intersting bimodal
5.0.4 Maker ID & Maker POLITICS
**Is there an association between MAKER ID and MAKER POLITICS? We hypothesize that when the MAKER ID is identified as POLITICAL, the MAKER POLITICS score will be more strongly associated with either ends of the semantic differential scale (ie. left leaning or right leaning). We expect this to not be the case with the other MAKER ID values.
To test this hypothesis, we will model MAKER_ID as a predictor of MAKER_POLITICS_ABS (the absolute value of the collapsed maker politics sd scale), where 0 = the midpoint of the original scale, and 50 = both the 0 and 100 pts of the original scale
df <- df_graphs_abs
## Does MAKER POLITICS depend on MAKER ID?
##RIDGEPLOT w/ MEAN
answers <- levels(df$MAKER_ID)
left <- rep(ref_labels_abs['MAKER_POLITIC','left'], length(levels(df$MAKER_ID)))
right <- rep(ref_labels_abs['MAKER_POLITIC','right'], length(levels(df$MAKER_ID)))
df %>%
group_by(MAKER_ID) %>%
mutate(
count = n(),
m = mean(MAKER_POLITIC),
md = median(MAKER_POLITIC)
) %>%
ggplot(aes(y = fct_rev(MAKER_ID), x= MAKER_POLITIC, fill = fct_rev(MAKER_ID))) +
scale_x_continuous(limits = c(0,50))+
geom_density_ridges(scale = 0.55,quantile_lines = TRUE, alpha = 0.75) +
stat_pointinterval(side = "bottom", scale = 0.7, slab_linewidth = NA, point_interval = "mean_qi") +
##MEDIAN
stat_summary(fun=median, geom="text", colour="red", fontface = "bold", size = 2.5,
vjust=+2, hjust = 0, aes( label=round(md, digits=0)))+
stat_summary(fun=median, geom="point", shape=20, size=3, color="red", fill="red") +
##MEAN
stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold", size = 2.5,
vjust=+2, hjust = 0, aes( label=round(m, digits=0)))+
stat_summary(fun="mean", geom="point", shape=20, size=3, color="blue", fill="blue") +
scale_fill_manual(values = my_palettes(name="reds", direction = "-1"), name = "", guide = guide_legend(reverse = TRUE)) +
guides(
y = guide_axis_manual(labels = left, title = ""),
y.sec = guide_axis_manual(labels = right)
) +
geom_text(aes(label= paste0("n=",count) , y = MAKER_ID, x = 50), color = "black",size = 3, nudge_y = 0.25) +
cowplot::draw_text(text = toupper(answers), x = 0, y= answers, size = 10, vjust=-2, hjust=0) +
labs (title = "POLITICS (absolute value) by MAKER ID", y = "", x = "MAKER POLITICS", caption="(mean in blue) (median in red)") +
theme_minimal() + easy_remove_legend()
Once the MAKER_POLITICS score has been collapsed to the SD scale, we see that our hypothesis is likely false, as the mean (absolute value) maker_politics scores are nearly the same for individual, organization and politics, with only news, education and business being slighly more neutral.
5.0.4.1 (NO) model
### LINEAR MIXED EFFECTS MODEL ##################
df <- df_graphs_abs
## DEFINE MODEL
f <- "MAKER_POLITIC ~ MAKER_ID + (1|PID) + (1|STIMULUS)"
m1 <-lmer(MAKER_POLITIC ~ MAKER_ID + (1|PID) + (1|STIMULUS), data=df)
## PRINT MODEL
(m_eq <- extract_eq(m1, use_coef = TRUE, ital_vars = TRUE, coef_digits = 1, wrap = TRUE, intercept = "beta"))\[ \begin{aligned} \widehat{MAKER\_POLITIC}_{i} &\sim N \left(13.5_{\alpha_{j[i],k[i]}}, \sigma^2 \right) \\ \alpha_{j} &\sim N \left(0.2_{\gamma_{1}^{\alpha}}(MAKER\_ID_{organization}) - 3.8_{\gamma_{2}^{\alpha}}(MAKER\_ID_{education}) - 1.6_{\gamma_{3}^{\alpha}}(MAKER\_ID_{business}) - 2.2_{\gamma_{4}^{\alpha}}(MAKER\_ID_{news}) - 0.6_{\gamma_{5}^{\alpha}}(MAKER\_ID_{political}), 7.1 \right) \text{, for PID j = 1,} \dots \text{,J} \\ \alpha_{k} &\sim N \left(0, 4.3 \right) \text{, for STIMULUS k = 1,} \dots \text{,K} \end{aligned} \]
## DESCRIBE MODEL
summary(m1)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: MAKER_POLITIC ~ MAKER_ID + (1 | PID) + (1 | STIMULUS)
## Data: df
##
## REML criterion at convergence: 12415.2
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -2.7909 -0.6304 -0.1448 0.5097 3.5618
##
## Random effects:
## Groups Name Variance Std.Dev.
## PID (Intercept) 50.43 7.102
## STIMULUS (Intercept) 18.61 4.314
## Residual 110.97 10.534
## Number of obs: 1590, groups: PID, 318; STIMULUS, 25
##
## Fixed effects:
## Estimate Std. Error df t value
## (Intercept) 13.5486 1.3324 98.2476 10.169
## MAKER_IDorganization 0.2037 1.4183 1441.9854 0.144
## MAKER_IDeducation -3.8306 1.0675 1419.5318 -3.588
## MAKER_IDbusiness -1.6098 1.1289 1446.1837 -1.426
## MAKER_IDnews -2.1858 1.1633 1431.8305 -1.879
## MAKER_IDpolitical -0.6456 1.2232 1448.0104 -0.528
## Pr(>|t|)
## (Intercept) < 0.0000000000000002 ***
## MAKER_IDorganization 0.885800
## MAKER_IDeducation 0.000344 ***
## MAKER_IDbusiness 0.154079
## MAKER_IDnews 0.060448 .
## MAKER_IDpolitical 0.597713
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) MAKER_IDr MAKER_IDd MAKER_IDb MAKER_IDn
## MAKER_IDrgn -0.425
## MAKER_IDdct -0.589 0.509
## MAKER_IDbsn -0.574 0.493 0.701
## MAKER_IDnws -0.579 0.502 0.682 0.662
## MAKER_IDplt -0.557 0.478 0.642 0.625 0.655anova(m1)## Type III Analysis of Variance Table with Satterthwaite's method
## Sum Sq Mean Sq NumDF DenDF F value Pr(>F)
## MAKER_ID 2462.2 492.43 5 1412.4 4.4377 0.0005147 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1performance(m1)## # Indices of model performance
##
## AIC | AICc | BIC | R2 (cond.) | R2 (marg.) | ICC | RMSE | Sigma
## ------------------------------------------------------------------------------------
## 12433.197 | 12433.311 | 12481.540 | 0.390 | 0.011 | 0.384 | 9.687 | 10.534report(m1)## We fitted a linear mixed model (estimated using REML and nloptwrap optimizer)
## to predict MAKER_POLITIC with MAKER_ID (formula: MAKER_POLITIC ~ MAKER_ID). The
## model included PID as random effects (formula: list(~1 | PID, ~1 | STIMULUS)).
## The model's total explanatory power is substantial (conditional R2 = 0.39) and
## the part related to the fixed effects alone (marginal R2) is of 0.01. The
## model's intercept, corresponding to MAKER_ID = individual, is at 13.55 (95% CI
## [10.94, 16.16], t(1581) = 10.17, p < .001). Within this model:
##
## - The effect of MAKER ID [organization] is statistically non-significant and
## positive (beta = 0.20, 95% CI [-2.58, 2.99], t(1581) = 0.14, p = 0.886; Std.
## beta = 0.01, 95% CI [-0.19, 0.22])
## - The effect of MAKER ID [education] is statistically significant and negative
## (beta = -3.83, 95% CI [-5.92, -1.74], t(1581) = -3.59, p < .001; Std. beta =
## -0.28, 95% CI [-0.43, -0.13])
## - The effect of MAKER ID [business] is statistically non-significant and
## negative (beta = -1.61, 95% CI [-3.82, 0.60], t(1581) = -1.43, p = 0.154; Std.
## beta = -0.12, 95% CI [-0.28, 0.04])
## - The effect of MAKER ID [news] is statistically non-significant and negative
## (beta = -2.19, 95% CI [-4.47, 0.10], t(1581) = -1.88, p = 0.060; Std. beta =
## -0.16, 95% CI [-0.32, 6.97e-03])
## - The effect of MAKER ID [political] is statistically non-significant and
## negative (beta = -0.65, 95% CI [-3.04, 1.75], t(1581) = -0.53, p = 0.598; Std.
## beta = -0.05, 95% CI [-0.22, 0.13])
##
## Standardized parameters were obtained by fitting the model on a standardized
## version of the dataset. 95% Confidence Intervals (CIs) and p-values were
## computed using a Wald t-distribution approximation.## PLOT MODEL COEFFICIENTS
coefs <- model_parameters(m1)
plot_model(m1, type = "est",
show.intercept = TRUE,
show.values = TRUE,
show.p = TRUE
) + theme_minimal() + labs(caption=f)
## PLOT MODEL PREDICTIONS
means <- estimate_means(m1, at = c("MAKER_ID"))
# sjPlot::plot_model(m1, type = "pred", terms = c("MAKER_ID")) +
# theme_minimal() + labs(caption=f)
# plot(means) + theme_minimal() + labs(caption=f) +
# geom_text(aes(x=means$MAKER_ID, y=means$Mean, label=round(means$Mean,1)),
# color="blue", position = position_nudge(x=0.25))
## PLOT MODEL PREDICTIONS with CONTRASTS
## contrasts
# black = estimated means and CI range; grey = CI range of the difference (as compared to the point estimate).
(contrasts <- estimate_contrasts(m1, contrast="MAKER_ID", method="pairwise"))## Marginal Contrasts Analysis
##
## Level1 | Level2 | Difference | 95% CI | SE | df | t | p
## -------------------------------------------------------------------------------------------
## business | news | 0.58 | [-2.20, 3.35] | 0.94 | 1401.87 | 0.61 | > .999
## business | political | -0.96 | [-3.98, 2.05] | 1.02 | 1406.24 | -0.94 | > .999
## education | business | -2.22 | [-4.73, 0.28] | 0.85 | 1379.01 | -2.61 | 0.111
## education | news | -1.64 | [-4.28, 0.99] | 0.90 | 1388.80 | -1.84 | 0.673
## education | political | -3.18 | [-6.07, -0.30] | 0.98 | 1416.16 | -3.25 | 0.017
## individual | business | 1.61 | [-1.72, 4.94] | 1.13 | 1448.29 | 1.42 | > .999
## individual | education | 3.83 | [ 0.69, 6.98] | 1.07 | 1421.56 | 3.58 | 0.005
## individual | news | 2.19 | [-1.24, 5.62] | 1.17 | 1434.73 | 1.87 | 0.673
## individual | organization | -0.20 | [-4.38, 3.97] | 1.42 | 1442.00 | -0.14 | > .999
## individual | political | 0.65 | [-2.96, 4.25] | 1.23 | 1450.78 | 0.53 | > .999
## news | political | -1.54 | [-4.46, 1.38] | 0.99 | 1409.69 | -1.55 | 0.972
## organization | business | 1.81 | [-2.03, 5.66] | 1.31 | 1426.41 | 1.39 | > .999
## organization | education | 4.03 | [ 0.30, 7.77] | 1.27 | 1425.16 | 3.18 | 0.020
## organization | news | 2.39 | [-1.46, 6.24] | 1.31 | 1418.54 | 1.83 | 0.673
## organization | political | 0.85 | [-3.16, 4.85] | 1.36 | 1437.73 | 0.62 | > .999
##
## Marginal contrasts estimated at MAKER_ID
## p-value adjustment method: Holm (1979)plot(contrasts, means) +
geom_text(aes(x=means$MAKER_ID, y=means$Mean, label=round(means$Mean,1)), color="blue", position = position_nudge(x=0.25)) +
theme_minimal() + labs(caption = f)
The results of the model confirm our suspicion that our hypothesis is not supported by the data. MAKER_ID is not a strong predictor of MAKER_POLITICS (absolute value). Post-hoc contrasts demonstrate that the mean values of some levels are significantly different (e.g individual v. education, organization v. education, education v. political) however the overall model does not indicate a good fit.
5.0.5 Maker ID & Maker TRUST
**Do people indicate higher TRUST in artifacts they attribute to EDUCATION type makers?
df <- df_graphs
## Does MAKER_TRUST depend on MAKER ID?
##RIDGEPLOT w/ MEAN
answers <- levels(df$MAKER_ID)
left <- rep(ref_labels['MAKER_TRUST','left'], length(levels(df$MAKER_ID)))
right <- rep(ref_labels['MAKER_TRUST','right'], length(levels(df$MAKER_ID)))
df %>%
group_by(MAKER_ID) %>%
mutate(
count = n(),
m=mean(MAKER_TRUST),
md=median(MAKER_TRUST)
) %>%
ggplot(aes(y = fct_rev(MAKER_ID), x= MAKER_TRUST, fill = fct_rev(MAKER_ID))) +
scale_x_continuous(limits = c(0,100))+
geom_density_ridges(scale = 0.55,quantile_lines = TRUE, alpha = 0.75) +
stat_pointinterval(side = "bottom", scale = 0.7, slab_linewidth = NA, point_interval = "mean_qi") +
##MEDIAN
stat_summary(fun=median, geom="text", colour="red", fontface = "bold", size = 2.5,
vjust=+2, hjust = 0, aes( label=round(md, digits=0)))+
stat_summary(fun=median, geom="point", shape=20, size=3, color="red", fill="red") +
## MEAN
stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold", size = 2.5,
vjust=+2, hjust = 0, aes( label=round(m, digits=0)))+
stat_summary(fun="mean", geom="point", shape=20, size=3, color="blue", fill="blue") +
scale_fill_manual(values = my_palettes(name="reds", direction = "-1"), name = "", guide = guide_legend(reverse = TRUE)) +
guides(
y = guide_axis_manual(labels = left, title = ""),
y.sec = guide_axis_manual(labels = right)
) +
geom_text(aes(label= paste0("n=",count) , y = MAKER_ID, x = 100), color = "black",size = 3, nudge_y = 0.25) +
cowplot::draw_text(text = toupper(answers), x = 0, y= answers, size = 10, vjust=-2, hjust=0) +
labs (title = "MAKER TRUST by MAKER ID", y = "", x = "MAKER TRUST", caption="(mean in blue) (median in red)") +
theme_minimal() + easy_remove_legend()## Picking joint bandwidth of 4.55
5.0.5.1 (YES) model
### LINEAR MIXED EFFECTS MODEL ##################
df <- df_graphs
## DEFINE MODEL
f <- "MAKER_TRUST ~ MAKER_ID + (1|PID) + (1|STIMULUS)"
m1 <-lmer(MAKER_TRUST ~ MAKER_ID + (1|PID) + (1|STIMULUS), data=df)
## PRINT MODEL
(m_eq <- extract_eq(m1, use_coef = TRUE, ital_vars = TRUE, coef_digits = 1, wrap = TRUE, intercept = "beta"))\[ \begin{aligned} \widehat{MAKER\_TRUST}_{i} &\sim N \left(52.2_{\alpha_{j[i],k[i]}}, \sigma^2 \right) \\ \alpha_{j} &\sim N \left(5_{\gamma_{1}^{\alpha}}(MAKER\_ID_{organization}) + 11.7_{\gamma_{2}^{\alpha}}(MAKER\_ID_{education}) + 1.6_{\gamma_{3}^{\alpha}}(MAKER\_ID_{business}) + 6.4_{\gamma_{4}^{\alpha}}(MAKER\_ID_{news}) + 1.6_{\gamma_{5}^{\alpha}}(MAKER\_ID_{political}), 7.1 \right) \text{, for PID j = 1,} \dots \text{,J} \\ \alpha_{k} &\sim N \left(0, 5.5 \right) \text{, for STIMULUS k = 1,} \dots \text{,K} \end{aligned} \]
## DESCRIBE MODEL
summary(m1)## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: MAKER_TRUST ~ MAKER_ID + (1 | PID) + (1 | STIMULUS)
## Data: df
##
## REML criterion at convergence: 13527.9
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -3.4861 -0.5306 -0.0062 0.5833 2.7640
##
## Random effects:
## Groups Name Variance Std.Dev.
## PID (Intercept) 49.79 7.056
## STIMULUS (Intercept) 30.35 5.509
## Residual 247.90 15.745
## Number of obs: 1590, groups: PID, 318; STIMULUS, 25
##
## Fixed effects:
## Estimate Std. Error df t value Pr(>|t|)
## (Intercept) 52.232 1.795 108.126 29.106 < 0.0000000000000002
## MAKER_IDorganization 5.030 2.068 1518.206 2.432 0.015118
## MAKER_IDeducation 11.706 1.560 1484.176 7.506 0.000000000000105
## MAKER_IDbusiness 1.622 1.642 1512.352 0.988 0.323356
## MAKER_IDnews 6.375 1.693 1485.447 3.765 0.000173
## MAKER_IDpolitical 1.633 1.776 1503.328 0.919 0.358119
##
## (Intercept) ***
## MAKER_IDorganization *
## MAKER_IDeducation ***
## MAKER_IDbusiness
## MAKER_IDnews ***
## MAKER_IDpolitical
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) MAKER_IDr MAKER_IDd MAKER_IDb MAKER_IDn
## MAKER_IDrgn -0.458
## MAKER_IDdct -0.635 0.508
## MAKER_IDbsn -0.617 0.490 0.695
## MAKER_IDnws -0.622 0.498 0.677 0.657
## MAKER_IDplt -0.599 0.475 0.639 0.620 0.650anova(m1)## Type III Analysis of Variance Table with Satterthwaite's method
## Sum Sq Mean Sq NumDF DenDF F value Pr(>F)
## MAKER_ID 25811 5162.2 5 1476.7 20.824 < 0.00000000000000022 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1performance(m1)## # Indices of model performance
##
## AIC | AICc | BIC | R2 (cond.) | R2 (marg.) | ICC | RMSE | Sigma
## -------------------------------------------------------------------------------------
## 13545.852 | 13545.966 | 13594.195 | 0.285 | 0.054 | 0.244 | 14.807 | 15.745report(m1)## We fitted a linear mixed model (estimated using REML and nloptwrap optimizer)
## to predict MAKER_TRUST with MAKER_ID (formula: MAKER_TRUST ~ MAKER_ID). The
## model included PID as random effects (formula: list(~1 | PID, ~1 | STIMULUS)).
## The model's total explanatory power is substantial (conditional R2 = 0.29) and
## the part related to the fixed effects alone (marginal R2) is of 0.05. The
## model's intercept, corresponding to MAKER_ID = individual, is at 52.23 (95% CI
## [48.71, 55.75], t(1581) = 29.11, p < .001). Within this model:
##
## - The effect of MAKER ID [organization] is statistically significant and
## positive (beta = 5.03, 95% CI [0.97, 9.09], t(1581) = 2.43, p = 0.015; Std.
## beta = 0.27, 95% CI [0.05, 0.49])
## - The effect of MAKER ID [education] is statistically significant and positive
## (beta = 11.71, 95% CI [8.65, 14.77], t(1581) = 7.51, p < .001; Std. beta =
## 0.63, 95% CI [0.46, 0.79])
## - The effect of MAKER ID [business] is statistically non-significant and
## positive (beta = 1.62, 95% CI [-1.60, 4.84], t(1581) = 0.99, p = 0.323; Std.
## beta = 0.09, 95% CI [-0.09, 0.26])
## - The effect of MAKER ID [news] is statistically significant and positive (beta
## = 6.38, 95% CI [3.05, 9.70], t(1581) = 3.76, p < .001; Std. beta = 0.34, 95% CI
## [0.16, 0.52])
## - The effect of MAKER ID [political] is statistically non-significant and
## positive (beta = 1.63, 95% CI [-1.85, 5.12], t(1581) = 0.92, p = 0.358; Std.
## beta = 0.09, 95% CI [-0.10, 0.27])
##
## Standardized parameters were obtained by fitting the model on a standardized
## version of the dataset. 95% Confidence Intervals (CIs) and p-values were
## computed using a Wald t-distribution approximation.## PLOT MODEL COEFFICIENTS
coefs <- model_parameters(m1)
plot_model(m1, type = "est",
show.intercept = TRUE,
show.values = TRUE,
show.p = TRUE
) + theme_minimal() + labs(caption=f)
## PLOT MODEL PREDICTIONS
means <- estimate_means(m1, at = c("MAKER_ID"))
# sjPlot::plot_model(m1, type = "pred", terms = c("MAKER_ID")) +
# theme_minimal() + labs(caption=f)
# plot(means) + theme_minimal() + labs(caption=f) +
# geom_text(aes(x=means$MAKER_ID, y=means$Mean, label=round(means$Mean,1)),
# color="blue", position = position_nudge(x=0.25))
## PLOT MODEL PREDICTIONS with CONTRASTS
## contrasts
# black = estimated means and CI range; grey = CI range of the difference (as compared to the point estimate).
(contrasts <- estimate_contrasts(m1, contrast="MAKER_ID", method="pairwise"))## Marginal Contrasts Analysis
##
## Level1 | Level2 | Difference | 95% CI | SE | df | t | p
## ------------------------------------------------------------------------------------------------
## business | news | -4.75 | [ -8.83, -0.68] | 1.39 | 1465.35 | -3.43 | 0.006
## business | political | -0.01 | [ -4.42, 4.40] | 1.50 | 1460.93 | -6.82e-03 | > .999
## education | business | 10.08 | [ 6.40, 13.77] | 1.25 | 1444.24 | 8.05 | < .001
## education | news | 5.33 | [ 1.46, 9.20] | 1.32 | 1447.18 | 4.05 | < .001
## education | political | 10.07 | [ 5.86, 14.29] | 1.43 | 1474.08 | 7.02 | < .001
## individual | business | -1.62 | [ -6.46, 3.22] | 1.65 | 1513.27 | -0.98 | > .999
## individual | education | -11.71 | [-16.30, -7.11] | 1.56 | 1485.07 | -7.49 | < .001
## individual | news | -6.38 | [-11.37, -1.38] | 1.70 | 1487.04 | -3.75 | 0.002
## individual | organization | -5.03 | [-11.12, 1.06] | 2.07 | 1518.40 | -2.43 | 0.107
## individual | political | -1.63 | [ -6.87, 3.61] | 1.78 | 1504.82 | -0.92 | > .999
## news | political | 4.74 | [ 0.46, 9.02] | 1.46 | 1479.72 | 3.26 | 0.009
## organization | business | 3.41 | [ -2.22, 9.03] | 1.91 | 1502.81 | 1.78 | 0.450
## organization | education | -6.68 | [-12.13, -1.22] | 1.86 | 1501.53 | -3.60 | 0.003
## organization | news | -1.35 | [ -6.97, 4.28] | 1.91 | 1493.53 | -0.70 | > .999
## organization | political | 3.40 | [ -2.45, 9.24] | 1.99 | 1514.87 | 1.71 | 0.450
##
## Marginal contrasts estimated at MAKER_ID
## p-value adjustment method: Holm (1979)plot(contrasts, means) +
geom_text(aes(x=means$MAKER_ID, y=means$Mean, label=round(means$Mean,1)), color="blue", position = position_nudge(x=0.25)) +
theme_minimal() + labs(caption = f)
6 STASH
wip code stash
6.1 sparkline table examples
# library(tinytable)
#
#
# ################################# CARS
# plot_data <- list(mtcars$mpg, mtcars$hp, mtcars$qsec)
#
# dat <- data.frame(
# Variables = c("mpg","hp","qsec"),
# Histogram="",
# Density="",
# Bar=""
# )
#
# tt(dat) %>%
# plot_tt(j=2, fun = "histogram", data = plot_data) %>%
# plot_tt(j=3, fun = "density", data = plot_data) %>%
# plot_tt(j=4, fun = "bar", data = list(2,3,6))
# # plot_tt(j=5, fun = "line", data = plot_data) %>%
# # style_tt(j = 2:3, align = "c")
#
# #################################
#
#
#
# ###################### GGPLOT CUSTOM GRAPH IN TABLE
#
#
# penguins<-read.csv( "https://vincentarelbundock.github.io/Rdatasets/csv/palmerpenguins/penguins.csv", na.strings= "") |> na.omit()
# #splitdatabyspecies
# dat<-split(penguins,penguins$species)
# body<-lapply(dat,\(x)x$body_mass_g)
# flip<-lapply(dat,\(x)x$flipper_length_mm)
# #createnearlyemptytable
# tab<-data.frame( "Species" =names(dat), "Body Mass"= "", "FlipperLength" ="", "Body vs. Flipper"= "", check.names= FALSE )
#
# #customggplot2functiontocreateinlineplot
# f<-function(d,...){
# ggplot(d,aes(x= flipper_length_mm,y=body_mass_g, color= sex)) +
# geom_point(size= .2) + scale_x_continuous(expand=c(0,0))+
# scale_y_continuous(expand=c(0,0)) + scale_color_manual(values= c("#E69F00", "#56B4E9")) + theme_void() + theme(legend.position="none")
# }
#
# #`tinytable` calls
#
# tt(tab) |>
# plot_tt(j=2,fun= "histogram",data = body, height= 2)|>
# plot_tt(j=3,fun= "density", data= flip,height= 2) |>
# plot_tt(j=4,fun= f, data= dat, height= 2)|>
# style_tt(j= 2:4, align="c")
#################################6.2 half boxplot raincloud mean
# ## HALF BOXPLOT + DOTPLOT + MEAN
# ##############################
# H <- df %>%
# group_by(MAKER_AGE) %>%
# mutate(count = n(), m = mean(MAKER_CONF)) %>%
# ggplot(aes(y = MAKER_CONF, x = fct_rev(MAKER_AGE), color = fct_rev(MAKER_AGE))) +
# geom_half_boxplot(side="r", alpha = 0.5, aes(fill=fct_rev(MAKER_AGE))) +
# stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold",
# vjust=-0.75, hjust = 1, aes( label=round(..y.., digits=0)))+
# scale_color_manual(values = my_palettes(name="lightblues", direction = "-1"),
# guide = guide_legend(reverse = TRUE)) +
# scale_fill_manual(values = my_palettes(name="lightblues", direction = "-1"),
# guide = guide_legend(reverse = TRUE)) +
# stat_dotsinterval(side = "bottom", scale = 0.7, slab_linewidth = NA,
# aes(fill = fct_rev(MAKER_AGE)) , color="black", point_interval = "mean_qi") +
# stat_summary(fun="mean", geom="point", shape=20, size=5, color="blue", fill="blue") +
# geom_text(aes(label= paste0("n=",count) , y = 5), color = "black",
# size = 3, nudge_x=0.35) +
# labs(y="Maker Age Confidence", x="") +
# theme_minimal() +
# easy_remove_legend()+
# coord_flip()
# ##############################
# 6.3 wip confidence modelling
#
# ## [test-frame] Are the confidence scores significantly different for different questions?
# ## [model-frame] Does QUESTION predict CONFIDENCE, accounting for random variance in SUBJECT and STIMULUS?
#
#
# ## MIXED model with random variance only at subject (not stimulus)
# mm1 <- lmer( CONFIDENCE ~ QUESTION + (1|PID), data = df)
# # summary(mm1)
# # plot(check_model(mm1))
# # pm <- model_parameters(mm1)
# # plot(pm, show_labels = TRUE, show_intercept = TRUE) + labs(title = "CONFIDENCE ~ QUESTION + (1|PID)")
# # performance(mm1)
# # report(mm1)
#
#
# ## MIXED model with random variance only at subject AND stimulus
# mm2 <- lmer( CONFIDENCE ~ QUESTION + (1|PID) + (1|STIMULUS), data = df)
# # summary(mm2)
# # plot(check_model(mm2))
# # pm <- model_parameters(mm2)
# # plot_model(mm2)
# # plot(pm, show_labels = TRUE, show_intercept = TRUE) + labs(title = "CONFIDENCE ~ QUESTION + (1|PID) + (1|STIMULUS)")
# # performance(mm2)
# # report(mm2)
#
#
# ## MIXED model with random slope for question by person and random intercept by stimulus
# mm3 <- lmer( CONFIDENCE ~ QUESTION + (1 + QUESTION | PID) + (1|STIMULUS), data = df)
# # summary(mm3)
# # plot(check_model(mm3))
# # pm <- model_parameters(mm3)
# # plot(pm, show_labels = TRUE, show_intercept = TRUE) + labs(title = "CONFIDENCE ~ QUESTION + (1 + QUESTION | PID) + (1|STIMULUS)")
# # performance(mm3)
# # report(mm3)
#
#
# ## MIXED model with STIMULUS as FIXED effect and random intercept by person
# mm4 <- lmer( CONFIDENCE ~ QUESTION + STIMULUS + (1 | PID), data = df)
# # summary(mm4)
# # plot(check_model(mm4))
# # pm <- model_parameters(mm4)
# # plot(pm, show_labels = TRUE, show_intercept = FALSE) + labs(title = "CONFIDENCE ~ QUESTION + STIMULUS + (1 | PID)")
# # performance(mm4)
# # report(mm4)
#
# ## MIXED model with STIMULUS * QUESTION interaction and random intercept by person
# mm5 <- lmer( CONFIDENCE ~ QUESTION * STIMULUS + (1 | PID), data = df)
# # summary(mm5)
# # plot(check_model(mm5))
# # pm <- model_parameters(mm5)
# # plot(pm, show_labels = TRUE, show_intercept = FALSE) + labs(title = "CONFIDENCE ~ QUESTION * STIMULUS + (1 | PID)")
# # performance(mm5)
# # report(mm5)
#
#
# ## MIXED model with STIMULUS * QUESTION interaction and random intercept by person
# mmx <- lmer( CONFIDENCE ~ STIMULUS + (1 | PID) + (1 | QUESTION), data = df)
# # summary(mmx)
# # plot(check_model(mmx))
# # pm <- model_parameters(mmx)
# # plot(pm, show_labels = TRUE, show_intercept = FALSE) + labs(title = "CONFIDENCE ~ STIMULUS + (1 | PID) + (1 | QUESTION)")
# # performance(mmx)
# # report(mmx)
#
#
# ### COMPARE MODELS
# # compare_parameters(mm1,mm2,mm3, mm4, mm5, mmx)
# compare_performance(mm1,mm2,mm3, mm4, mm5, mmx, rank = TRUE )
# ## model 3 is the best fit, and is appropriate to the design of the study
# summary(mm3)
# report(mm3)
# # plot_model(mm3, terms = c("QUESTION", "STIMULUS"), type = "diag")
#
# # # ## repeated measures aov
# # print("Repeated Measures ANOVA")
# # ex1 <- aov(CONFIDENCE~QUESTION+Error(PID), data=df)
# # summary(ex1)
# # report(ex1)
# 6.4 correlation plot code
# ## SHADED CIRCLES
# corrplot(m, method = 'circle', type = 'lower',
# order = 'AOE', diag = FALSE,
# insig='blank',
# tl.col = "black")
#
#
# ## SHADED NUMBERS
# corrplot(m, order = 'AOE', method = "number",
# diag = FALSE, type = "lower",
# insig='blank',
# # insig = 'label_sig', sig.level = c(0.001, 0.01, 0.05),
# addCoef.col = '#595D60',
# tl.pos = "ld", tl.col = "#595D60")
#
#
# ## SHADED SQUARED + COEFFS
# corrplot(m, order = 'AOE', method = "circle",
# diag = FALSE, type = "lower",
# insig='blank', sig.level = 0.05,
# # insig = 'label_sig', sig.level = c(0.001, 0.01, 0.05),
# addCoef.col = '#595D60',
# tl.pos = "ld", tl.col = "#595D60")
# 6.5 flip some sds
############## SETUP FOR FLIPPING SCALES ON SOME QUESTIONS TO MAKE THEM MORE READABLE
ref_sd_reordered <- c("MAKER_DATA","MAKER_DESIGN",
"CHART_BEAUTY", "CHART_LIKE",
"MAKER_POLITIC","MAKER_ARGUE", "MAKER_SELF", "CHART_INTENT",
"MAKER_ALIGN","MAKER_TRUST",
"CHART_TRUST")
left_reordered <- c("layperson","layperson",
"NOT at all","NOT at all",
"left-leaning",
"diplomatic",
"altruistic",
"inform",
"DOES share",
"untrustworthy",
"untrustworthy")
right_reordered <- c("professional","professional",
"very much", "very much",
"right-leaning",
"confrontational",
"selfish",
"persuade",
"does NOT share",
"trustworthy",
"trusthworthy")
ref_labels_reordered <- as.data.frame(cbind(left_reordered,right_reordered))
rownames(ref_labels_reordered) <- ref_sd_questions6.6 correlation matrix
## GGALLY correlation heatmap
# ggcorr(df,
# label = TRUE, geom = "tile",
# nbreaks = 5, layout.exp = 2,
# # label_round = 2,
# angle = -0, hjust = 0.8, vjust = 1, size = 2.5,
# low = "#D88585",mid = "white", high= "#6DA0D6") +
# easy_remove_legend() +
# labs(title = "Correlation between SD measures", subtitle = ("pairwise; Pearson correlations"))6.7 ridgeplot with interval and mean
# ## Does MAKER_TRUST depend on MAKER ID?
# ##RIDGEPLOT w/ MEAN
# answers <- levels(df$MAKER_ID)
# left <- rep(ref_labels['MAKER_TRUST','left'], length(levels(df$MAKER_ID)))
# right <- rep(ref_labels['MAKER_TRUST','right'], length(levels(df$MAKER_ID)))
# df %>% ggplot(aes(y = fct_rev(MAKER_ID), x= MAKER_TRUST, fill = fct_rev(MAKER_ID))) +
# geom_density_ridges(scale = 0.55,quantile_lines = TRUE, alpha = 0.75) +
# stat_dotsinterval(side = "bottom", scale = 0.7, slab_linewidth = NA, point_interval = "mean_qi") +
# stat_summary(fun=mean, geom="text", colour="blue", fontface = "bold",
# vjust=+2, hjust = 0, aes( label=round(..x.., digits=0)))+
# stat_summary(fun="mean", geom="point", shape=20, size=5, color="blue", fill="blue") +
# scale_fill_manual(values = my_palettes(name="reds", direction = "-1"), name = "", guide = guide_legend(reverse = TRUE)) +
# guides(
# y = guide_axis_manual(labels = left, title = ""),
# y.sec = guide_axis_manual(labels = right)
# ) +
# cowplot::draw_text(text = toupper(answers), x = 10, y= answers,size = 10, vjust=-2) +
# labs (title = "MAKER TRUST by MAKER ID", y = "", x = "MAKER TRUST", caption="(mean in blue)") +
# theme_minimal() + easy_remove_legend()6.8 lessR donuts
##good for seeing the color schemes
# #### DEFINE SET
# stimulus = "B2-1"
# df <- df_graphs %>% filter(STIMULUS == stimulus)
#
# #### GENERATE GRAPHS
#
# #MAKER_ID-DONUT
# PieChart(MAKER_ID, data = df,
# fill = "reds",
# main = paste0(stimulus, " MAKER ID")) + theme_minimal()
#
#
# #MAKER_GENDER-DONUT
# PieChart(MAKER_GENDER, data = df,
# fill = "blues",
# main = paste0(stimulus, " MAKER GENDER")) + theme_minimal()
#
#
# #MAKER_AGE-DONUT
# PieChart(MAKER_AGE, data = df,
# fill = "olives",
# main = paste0(stimulus, " MAKER AGE")) + theme_minimal()
#
# #MAKER_AGE-DONUT
# PieChart(MAKER_ID, data = df,
# fill = "rusts",
# main = paste0(stimulus, " MAKER AGE")) + theme_minimal()
#
# #MAKER_AGE-DONUT
# PieChart(MAKER_ID, data = df,
# fill = "olives",
# main = paste0(stimulus, " MAKER AGE")) + theme_minimal()
#
# #MAKER_AGE-DONUT
# PieChart(MAKER_ID, data = df,
# fill = "greens",
# main = paste0(stimulus, " MAKER AGE")) + theme_minimal()
#
# #MAKER_AGE-DONUT
# PieChart(MAKER_ID, data = df,
# fill = "emeralds",
# main = paste0(stimulus, " MAKER AGE")) + theme_minimal()
#
# #MAKER_AGE-DONUT
# PieChart(MAKER_ID, data = df,
# fill = "turquoises",
# main = paste0(stimulus, " MAKER AGE")) + theme_minimal()
#
# #MAKER_AGE-DONUT
# PieChart(MAKER_ID, data = df,
# fill = "aquas",
# main = paste0(stimulus, " MAKER AGE")) + theme_minimal()
#
# #MAKER_AGE-MAKER_ID
# PieChart(MAKER_ID, data = df,
# fill = "purples",
# main = paste0(stimulus, " MAKER AGE")) + theme_minimal()
#
# #MAKER_AGE-DONUT
# PieChart(MAKER_ID, data = df,
# fill = "magentas",
# main = paste0(stimulus, " MAKER AGE")) + theme_minimal()
#
# #MAKER_AGE-DONUT
# PieChart(MAKER_ID, data = df,
# fill = "violets",
# main = paste0(stimulus, " MAKER AGE")) + theme_minimal()
#
# #MAKER_AGE-DONUT
# PieChart(MAKER_ID, data = df,
# fill = "grays",
# main = paste0(stimulus, " MAKER AGE")) + theme_minimal()
# "reds" h 0
# "rusts" h 30
# "browns" h 60
# "olives" h 90
# "greens" h 120
# "emeralds" h 150
# "turquoises" h 180
# "aquas" h 210
# "blues" h 240
# "purples" h 270
# "violets" h 300
# "magentas" h 330
# "grays"6.9 ggplot donuts
# df <- df_graphs %>% filter(STIMULUS== s)
# #### CATEGORICAL DONUT PLOTS
# #subset data cols
# cols <- df %>% select( all_of(ref_cat_questions))
#
# ggplot( df, aes( x = STIMULUS, fill = MAKER_ID)) +
# geom_bar( position = "stack", width=1) +
# coord_radial(theta = "y", start = 0, inner.radius = 0.5, expand=FALSE) +
# scale_fill_manual(values = my_palettes(name="reds", direction = "1"), name = "", guide = guide_legend(reverse = FALSE)) +
# labs( title = paste0(s, " MAKER ID")) +
# theme_minimal()
#
# 6.10 Alluvial Plots
## EXAMPLE ALLUVIAL PLOT USING GGALUVIAL (instead of GGSANKEY)
# https://corybrunson.github.io/ggalluvial/articles/ggalluvial.html
# #FILTER FOR BLOCK 2 STIM AND RESHAPE FOR SANKEY
# ds <- df_graphs %>%
# filter(str_detect(STIMULUS, "B2")) %>%
# select(STIMULUS, MAKER_ID, PID) %>%
# mutate(
# MAKER_ID = fct_relevel(MAKER_ID,
# c("business","education","individual", "news","organization", "political" ))
# )
#
# ds %>%
# ggplot(aes( x = STIMULUS,
# stratum = MAKER_ID,
# label = MAKER_ID,
# alluvium = PID)) +
# stat_alluvium(aes(fill = MAKER_ID),
# width = 0,
# alpha = 1,
# geom = "flow")+
# geom_stratum(width = 0.2, aes(fill= MAKER_ID))+
# # geom_text(stat = "stratum", size = 5, angle = 90)+
# scale_fill_viridis(discrete=TRUE, option="viridis", drop = FALSE,
# alpha = 1) +
# theme_minimal()6.11 AD and KS Tests Comparing of Distributions
Are the confidence distributions for each question different? Note that central tendency is not a good measure here, because we care a great deal about the shape of the distribution. KS Tests can be used to compare 2 empirical distributions (and AD tests more than 2) to against the null hypothesis that they were drawn from the same population. HOWEVER BOTH tests assume the variables are independent (i.e. not repeated measures or from the same sample) so it is not appropriate to use them to compare distributions of our survey vars
# df <- df_full
## PAIRWISE KS-TESTS
# ks.test(df$MAKER_CONF, df$AGE_CONF,
# alternative="two.sided",
# simulate.p.value = TRUE )
#
# ks.test(df$MAKER_CONF, df$GENDER_CONF,
# alternative="two.sided",
# simulate.p.value = TRUE )
#
# ks.test(df$MAKER_CONF, df$TOOL_CONF,
# alternative="two.sided",
# simulate.p.value = TRUE )
#
#
# ks.test(df$GENDER_CONF, df$AGE_CONF,
# alternative="two.sided",
# simulate.p.value = TRUE )
#
# ks.test(df$GENDER_CONF, df$TOOL_CONF,
# alternative="two.sided",
# simulate.p.value = TRUE )
#
# ks.test(df$AGE_CONF, df$TOOL_CONF,
# alternative="two.sided",
# simulate.p.value = TRUE )
#
#
# ## kSamples
# # library(kSamples)
# ad.test( df$MAKER_CONF, df$AGE_CONF, df$GENDER_CONF, df$TOOL_CONF,
# method = "asymptotic")6.12 Friedman rank Sum test comparing distirbutions unreplicated blocked data
#
# # setup dataframe
# df <- df_graphs
#
# ## COMPARE POLITICS, ARGUE, SELFISH, ALIGNMENT
#
#
# ## CHART LIKE AND CHART BEAUTY
# df <- df_sd_questions_long %>% select(PID, QUESTION, STIMULUS, value) %>%
# filter( QUESTION %in% c("CHART_LIKE", "CHART_BEAUTY")) %>%
# group_by(QUESTION, PID) %>% ## HAVE TO COLLAPSE ACROSS STIMULI TO RUN FREIDMAN TEST
# summarise(
# m_value=round(mean(value),0) #calc mean for showing in plots
# ) %>% droplevels()
#
# df <- as.data.frame(df)
# friedman.test( data = df, m_value ~ QUESTION | PID)
# ## EFFECT SIZE
# friedman_effsize( data = df, m_value ~ QUESTION | PID)
#
#
# ## CHART TRUST AND MAKER TRUST
# df <- df_sd_questions_long %>% select(PID, QUESTION, STIMULUS, value) %>%
# filter( QUESTION %in% c("CHART_TRUST", "MAKER_TRUST")) %>%
# group_by(QUESTION, PID) %>% ## HAVE TO COLLAPSE ACROSS STIMULI TO RUN FREIDMAN TEST
# summarise(
# m_value=round(mean(value),0) #calc mean for showing in plots
# ) %>% droplevels()
#
# df <- as.data.frame(df)
# friedman.test( data = df, m_value ~ QUESTION | PID)
# ## EFFECT SIZE
# friedman_effsize( data = df, m_value ~ QUESTION | PID)
#
#
#
# ## COMPARE POLITICS, ARGUE, SELFISH, ALIGNMENT
# df <- df_sd_questions_long %>% select(PID, QUESTION, STIMULUS, value) %>%
# filter( QUESTION %in% c("MAKER_POLITIC", "MAKER_ARGUE", "MAKER_SELFISH", "MAKER_ALIGN")) %>%
# group_by(QUESTION, PID) %>% ## HAVE TO COLLAPSE ACROSS STIMULI TO RUN FREIDMAN TEST
# summarise(
# m_value=round(mean(value),0) #calc mean for showing in plots
# ) %>% droplevels()
#
# df <- as.data.frame(df)
# friedman.test( data = df, m_value ~ QUESTION | PID)
# ## EFFECT SIZE
# friedman_effsize( data = df, m_value ~ QUESTION | PID)
#
#
#
#
# #### SOMETHING WE EXPECT TO BE VERY DIFFERENT
# ## DESIGN COMPETENCY AND POLITICS
# df <- df_sd_questions_long %>% select(PID, QUESTION, STIMULUS, value) %>%
# filter( QUESTION %in% c("MAKER_POLITIC", "MAKER_DESIGN")) %>%
# group_by(QUESTION, PID) %>% ## HAVE TO COLLAPSE ACROSS STIMULI TO RUN FREIDMAN TEST
# summarise(
# m_value=round(mean(value),0) #calc mean for showing in plots
# ) %>% droplevels()
#
# df <- as.data.frame(df)
# friedman_test( data = df, m_value ~ QUESTION | PID)
# ## EFFECT SIZE
# friedman_effsize( data = df, m_value ~ QUESTION | PID)
#
# gf_histogram(df, ~m_value) + facet_wrap(~QUESTION)7 RESOURCES
- custom color palettes: https://www.r-bloggers.com/2022/06/custom-colour-palettes-for-ggplot2/
- lessR donuts https://r-charts.com/part-whole/donut-chart/
- GGSANKEY https://github.com/davidsjoberg/ggsankey
- GGALLUVIAL https://corybrunson.github.io/ggalluvial/articles/ggalluvial.html
- variable standardization [variable (vs) participant] :https://cran.r-project.org/web/packages/datawizard/vignettes/standardize_data.html
- contrasts:
- UCLA:https://stats.oarc.ucla.edu/r/library/r-library-contrast-coding-systems-for-categorical-variables
- https://phillipalday.com/stats/lazy-contrasts.html
- level naming with contrasts :https://rpubs.com/bbolker/5335
- ggdist slab normaliztion https://mjskay.github.io/ggdist/articles/thickness.html
- visualizing regression models visreg https://pbreheny.github.io/visreg/index.html